args<-commandArgs(T)
if(length(args) != 3){
	stop("Rscript RCytoscape.r <node> <edge> <outprefix>")
}

library(RCytoscape)
g <- new('graphNEL', edgemode='undirected')
port = 9000

## read node file
node = read.table(args[1], sep="\t", comment.char = "`")
cl <- colorRampPalette(c("green", "white", "red"))(1000)
for (i in 1:nrow(node)){
	g <- graph::addNode(as.character(node[i,1]), g)
	if(node[i, 2] < -5)
	{
		node[i, 3] <- cl[1]
	}else if(node[i, 2] > 5){
		node[i, 3] <- cl[1000]
	}else if(node[i, 2] >= -5 && node[i, 2] <= 0){
		node[i, 3] <- cl[500 - as.integer(node[i, 2] * (-100))]
	}else{
		node[i, 3] <- cl[500 + as.integer(node[i, 2] * 100)]
	}
}

## read edge file
edge = read.table(args[2], sep="\t")
for (i in 1:nrow(edge)){
	g <- graph::addEdge(as.character(edge[i,1]), as.character(edge[i,2]), g)
}

## establish connection to Cytoscape
cy <- CytoscapeConnection(rpcPort = port)
deleteAllWindows(cy)
## init
setDefaultBackgroundColor(cy, '#ffffff')
cw <- new.CytoscapeWindow(args[3], graph=g, rpcPort = port)

##node
setDefaultNodeShape(cw, 'ellipse')
setDefaultNodeLabelColor(cw, '#000000')

##edge
setDefaultEdgeColor(cw, '#c0c0c0')

setWindowSize(cw, 8012, 8031)
displayGraph(cw)
## modif node color
for(i in 1:nrow(node))
{
	if(node[i, 2] < -1 || node[i, 2] > 1)
	{
		setNodeColorDirect(cw, as.character(node[i, 1]), as.character(node[i, 3]))
	}else{
		setNodeColorDirect(cw, as.character(node[i, 1]), "#ffffff")
	}
}
#control.points <- c(-3.0, 0.0, 3.0)
#node.colors <- c("#00AA00", "#00FF00", "#FFFFFF", "#FF0000", "#AA0000")
#setNodeColorRule(cw, node.attribute.name='label', control.points, node.colors, mode='interpolate')

## adjust network layout
layoutNetwork(cw, 'force-directed')
redraw(cw)
## adjust img size
zoom <- getZoom(cw) * 0.9
setZoom(cw, zoom)
## save img
id = paste(args[3], '.png', sep='')
saveImage(cw, id, 'png', 1.0)
id = paste(args[3], '.gml', sep='')
saveNetwork(cw, id, format='gml')


segmented_lines=function(lines) {
  cSl <- coordinates(lines)
  in_nrows <- lapply(cSl, function(x) sapply(x, nrow))
  outn <- sapply(in_nrows, function(y) sum(y-1))
  res <-list()

  i <- 1
  for (j in seq(along=cSl)) {
    for (k in seq(along=cSl[[j]])) {
      for (l in 1:(nrow(cSl[[j]][[k]])-1)) {
        res[[i]] <- cSl[[j]][[k]][l:(l+1),]
        i <- i + 1}}}

  res1 <- list();for (i in seq_along(res)) {res1[[i]] <- Lines(list(Line(res[[i]])), as.character(i))}
  outSL <- SpatialLines(res1)
  proj4string(outSL)=proj4string(lines)
  return(outSL);
}

orient_seg=function(linesobj) {
  message("work only single segment SpatialLines!")
  res_orient=list()
  for ( i in seq_along(linesobj)) {
    x=linesobj[i,]
    res_orient[[i]]=(2*pi+atan2(x@lines[[1]]@Lines[[1]]@coords[2,1]-x@lines[[1]]@Lines[[1]]@coords[1,1],x@lines[[1]]@Lines[[1]]@coords[2,2]-x@lines[[1]]@Lines[[1]]@coords[1,2]))*(180/pi)
  }

  temp=as.numeric(unlist(res_orient))
  return(temp)
}

axes_segment=function(orient){

if ( !(require(rBiometeo))) { devtools::install_github("alfcrisci/rBiometeo")}

sector=rBiometeo::compass_8(orient)
sector=sector_windstreet
idNE_SO=c(which(sector=="NE"),which(sector=="SW"))
idN_S=c(which(sector=="N"),which(sector=="S"))
idE_O=c(which(sector=="E"),which(sector=="W"))
idNW_SE=c(which(sector=="NW"),which(sector=="SE"))

sector_windstreet[idNE_SO]="asse_NE_SO"
sector_windstreet[idN_S]="asse_N_S"
sector_windstreet[idE_O]="asse_E_O"
sector_windstreet[idNW_SE]="asse_NW_SE"

return(data.frame(orient=orient,sector=sector,ax_wind=sector_windstreet))

}


#==============================================================================
#	Test for has.offset method in model.adapter.
#==============================================================================

library(testthat)
library(model.adapter)

#------------------------------------------------------------------------------
#	Create test data
#------------------------------------------------------------------------------
set.seed(12345)
test.data <- data.frame(
	x = rnorm(1000, 1000, 100),
	offset = runif(1000, 1, 10) %/% 1,
	random = runif(1000, 1, 100) %/% 1
)
test.data$y.norm <- rnorm(1000, test.data$x) * test.data$offset
test.data$y.pois <- rpois(1000, test.data$x) * test.data$offset
test.data$y.norm.with.random <- (
	rnorm(1000, test.data$x) * test.data$offset + rnorm(100)[test.data$random]
)
test.data$y.pois.with.random <- (
	rpois(1000, test.data$x + rnorm(100)[test.data$random]) * test.data$offset
)
test.data$random <- factor(test.data$random)

#------------------------------------------------------------------------------
#	party::cforest
#------------------------------------------------------------------------------
test_that(
	"Test handling of offset terms for party::cforest",
	{
		model <- party::cforest(
			y.pois ~ x + offset(offset),
			data = test.data, control = party::cforest_unbiased(mtry = 1)
		)
		expect_equal(
			model.adapter$new(model)$predict()$fit[, "fit"],
			predict(model, type = "response")[, "y.pois"]
		)
	}
)

#------------------------------------------------------------------------------
#	party::ctree
#------------------------------------------------------------------------------
test_that(
	"Test handling of offset terms for party::ctree", {
		model <- party::ctree(
			y.pois ~ x + offset(offset), data = test.data
		)
		expect_equal(
			model.adapter$new(model)$predict()$fit[, "fit"],
			predict(model, type = "response")[, "y.pois"]
		)
	}
)

#------------------------------------------------------------------------------
#	gam::gam
#------------------------------------------------------------------------------
library(gam)
test_that(
	"Test handling of offset terms for gam::gam with offset in formula", {
		model <- gam::gam(
			y.pois ~ x + offset(log(test.data$offset)), data = test.data,
			family = poisson(log)
		)
		expect_equal(
			model.adapter$new(model)$predict()$fit[, "fit"],
			predict(model, type = "response")
		)
	}
)

test_that(
	"Test handling of offset terms for gam::gam with offset argument", {
		model <- gam::gam(
			y.pois ~ x , data = test.data, family = poisson(log),
			offset = log(offset), control = gam::gam.control(maxit = 100)
		)
		expect_equal(
			model.adapter$new(model)$predict()$fit[, "fit"],
			predict(model, type = "response")
			* test.data$offset / mean(test.data$offset)
		)
	}
)

#------------------------------------------------------------------------------
#	mgcv::gam
#------------------------------------------------------------------------------
test_that(
	"Test handling of offset terms for mgcv::gam with offset in formula", {
		model <- mgcv::gam(
			y.pois ~ x + offset(log(offset)), data = test.data,
			family = poisson(log)
		)
		expect_equal(
			model.adapter$new(model)$predict()$fit[, "fit"],
			c(predict(model, type = "response"))
		)
	}
)

test_that(
	"Test handling of offset terms for mgcv::gam with offset argument", {
		model <- mgcv::gam(
			y.pois ~ x, data = test.data, offset = log(offset),
			family = poisson(log)
		)
		expect_equal(
			model.adapter$new(model)$predict()$fit[, "fit"],
			c(predict(model, type = "response") * test.data$offset)
		)
	}
)

#------------------------------------------------------------------------------
#	mgcv::gamm
#------------------------------------------------------------------------------
test_that(
	"Test handling of offset terms for mgcv::gamm with offset in formula", {
		test.data$log.offset <- log(test.data$offset)
		model <- mgcv::gamm(
			y.pois.with.random ~ x + offset(log.offset),
			random = list(random = ~ 1),
			data = test.data, family = poisson(log)
		)
		expect_equal(
			model.adapter$new(model)$predict()$fit[, "fit"],
			c(predict(model$gam, type = "response"))
		)
	}
)

#------------------------------------------------------------------------------
#	gbm::gbm
#------------------------------------------------------------------------------
library(gbm)
test_that(
	"Test handling of offset terms for gbm::gbm with offset in formula", {
		model <- gbm::gbm(
			y.pois ~ x + offset(log(offset)),
			data = test.data, distribution = "poisson", n.trees = 100
		)
		adapter <- model.adapter$new(model)
		expect_equal(
			adapter$predict(newdata = test.data, n.trees = 100)$fit[, "fit"],
			suppressWarnings(
				predict(model, type = "response", n.trees = 100)
				* test.data$offset
			)
		)
	}
)

#------------------------------------------------------------------------------
#	stats::glm
#------------------------------------------------------------------------------
test_that(
	"Test handling of offset terms for stats::glm with offset in formula", {
		model <- stats::glm(
			y.pois ~ x + offset(log(offset)), data = test.data,
			family = poisson
		)
		expect_equal(
			model.adapter$new(model)$predict()$fit[, "fit"],
			predict(model, type = "response")
		)
	}
)

test_that(
	"Test handling of offset terms for stats::glm with offset argument", {
		model <- stats::glm(
			y.pois ~ x, offset = log(offset), data = test.data,
			family = poisson
		)
		expect_equal(
			model.adapter$new(model)$predict()$fit[, "fit"],
			predict(model, type = "response")
		)
	}
)

#------------------------------------------------------------------------------
#	lme4::glmer
#------------------------------------------------------------------------------
library(lme4)
test_that(
	"Test handling of offset terms for lme4::glmer with offset in formula", {
		model <- lme4::glmer(
			y.pois.with.random ~ x + (1 | random) + offset(log(offset)),
			data = test.data, family = poisson
		)
		expect_equal(
			model.adapter$new(model)$predict()$fit[, "fit"],
			predict(model, type = "response")
		)
	}
)

test_that(
	"Test handling of offset terms for lme4::glmer with offset argument", {
		model <- lme4::glmer(
			y.pois.with.random ~ x + (1 | random), offset = log(offset),
			data = test.data, family = poisson
		)
		expect_equal(
			model.adapter$new(model)$predict()$fit[, "fit"],
			predict(model, type = "response")
		)
	}
)

#------------------------------------------------------------------------------
#	glmmADMB::glmmadmb
#------------------------------------------------------------------------------
library(glmmADMB)
test_that(
	paste(
		"Test handling of offset terms for glmmADMB::glmmadmb with offset in",
		"formula"
	), {
		model <- glmmADMB::glmmadmb(
			y.norm ~ x + offset(offset), data = test.data, family = "gaussian"
		)
		expect_equal(
			model.adapter$new(model)$predict()$fit[, "fit"],
			predict(model, type = "response")
			* test.data$offset / mean(test.data$offset)
		)
	}
)

#------------------------------------------------------------------------------
#	stats::lm
#------------------------------------------------------------------------------
test_that(
	"Test handling of offset terms for stats::lm with offset in formula", {
		model <- stats::lm(y.norm ~ x + offset(offset), data = test.data)
		expect_equal(
			model.adapter$new(model)$predict()$fit[, "fit"],
			predict(model) * test.data$offset / mean(test.data$offset)
		)
	}
)

test_that(
	"Test handling of offset terms for stats::lm with offset argument", {
		model <- stats::lm(y.norm ~ x, offset = offset, data = test.data)
		expect_equal(
			model.adapter$new(model)$predict()$fit[, "fit"],
			predict(model) * test.data$offset / mean(test.data$offset)
		)
	}
)

#------------------------------------------------------------------------------
#	nlme::lme
#------------------------------------------------------------------------------
library(nlme)
test_that(
	"Test handling of offset terms for nlme::lme with offset in formula", {
		model <- nlme::lme(
			y.norm.with.random ~ x + offset(offset), data = test.data,
			random = ~ 1 | random
		)
		expect_equal(
			model.adapter$new(model)$predict()$fit[, "fit"],
			c(predict(model, level = 0))
			* test.data$offset / mean(test.data$offset)
		)
	}
)

#------------------------------------------------------------------------------
#	lme4::lmer
#------------------------------------------------------------------------------
test_that(
	"Test handling of offset terms for lme4::lmer with offset in formula", {
		model <- lme4::lmer(
			y.norm.with.random ~ x + (1 | random) + offset(offset),
			data = test.data
		)
		expect_equal(
			model.adapter$new(model)$predict()$fit[, "fit"],
			predict(model) * test.data$offset / mean(test.data$offset)
		)
	}
)

test_that(
	"Test handling of offset terms for lme4::lmer with offset argument", {
		model <- lme4::lmer(
			y.norm.with.random ~ x + (1 | random), offset = offset,
			data = test.data
		)
		expect_equal(
			model.adapter$new(model)$predict()$fit[, "fit"],
			predict(model) * test.data$offset / mean(test.data$offset)
		)
	}
)

#------------------------------------------------------------------------------
#	MCMCglmm::MCMCglmm
#------------------------------------------------------------------------------
test_that(
	paste(
		"Test handling of offset terms for MCMCglmm::MCMCglmm with offset in",
		"formula"
	), {
		model <- MCMCglmm::MCMCglmm(
			y.pois ~ x + offset(log(offset)), data = test.data,
			family = "poisson", verbose = FALSE
		)
		adapter <- model.adapter$new(model)
		expect_true(
			all(
				adapter$predict(newdata = test.data)$fit[, "fit"]
				== predict(model) * test.data$offset / mean(test.data$offset)
			)
		)
	}
)

#------------------------------------------------------------------------------
#	randomForest::randomForest
#------------------------------------------------------------------------------
library(randomForest)
test_that(
	paste(
		"Test handling of offset terms for randomForest::randomForest",
		"with offset in formula"
	), {
		model <- randomForest::randomForest(
			y.norm ~ x + offset(offset), data = test.data
		)
		expect_equal(
			model.adapter$new(model)$predict()$fit[, "fit"],
			predict(model) * test.data$offset / mean(test.data$offset)
		)
	}
)

#------------------------------------------------------------------------------
#	rpart::rpart
#------------------------------------------------------------------------------
library(rpart)
test_that(
	"Test handling of offset terms for rpart::rpart with offset in formula", {
		model <- rpart::rpart(y.norm ~ x + offset(offset), data = test.data)
		expect_equal(
			model.adapter$new(model)$predict()$fit[, "fit"],
			predict(model) * test.data$offset / mean(test.data$offset)
		)
	}
)

#------------------------------------------------------------------------------
#	e1071::svm
#------------------------------------------------------------------------------
library(e1071)
test_that(
	"Test handling of offset terms for e1071::svm with offset in formula", {
		model <- e1071::svm(y.norm ~ x + offset(offset), data = test.data)
		expect_equal(
			model.adapter$new(model)$predict()$fit[, "fit"],
			predict(model) * test.data$offset / mean(test.data$offset)
		)
	}
)

#------------------------------------------------------------------------------
#	tree::tree
#------------------------------------------------------------------------------
library(tree)
test_that(
	"Test handling of offset terms for e1071::svm with offset in formula", {
		model <- tree::tree(y.norm ~ x + offset(offset), data = test.data)
		expect_equal(
			model.adapter$new(model)$predict()$fit[, "fit"],
			predict(model) * test.data$offset / mean(test.data$offset)
		)
	}
)


#name: covariates
#language: r
#input: string coVariates
#input: dataframe covariatesDf
#output: graphics plot
#output: dataframe diagnostics

renv::init()
renv::install("ggfortify")

require("ggfortify")
require("survival")
require("ggplot2")

diagnostics = as.data.frame(installed.packages()[,c(1,3:4)])

modform <- as.formula(paste("Surv(time, status)", coVariates, sep = " ~ "))

aa_fit <- aareg(modform, data = covariatesDf)

autoplot(aa_fit) +
  theme_bw()


#' plot a "gel" like diagram showing expression of a gene of interest over metacells that are classified into types
#'
#' @param mc_id id of metacell object in scdb
#' @param gene_nm gene of interest
#' @param reorder_preset list of mc colors to define the "lanes"
#' @param reorder should metacell types be sorted by gene intesity?
#' @param plot_title display gene name as plot's title
#'
#' @export

mcell_mc_plot_vgels = function(mc_id, gene_nms,
							reorder_preset=NULL, reorder=F, fig_fn = NULL,
							lane_w=50, height=350, plot_title=F)
{
	mc = scdb_mc(mc_id)
	if(is.null(mc)) {
		stop("undefined meta cell object " , mc_id)
	}

	fdir = scfigs_dir(mc_id, "gels")
	for(gene_nm in gene_nms) {
		message("iter ", gene_nm)
		if(! gene_nm %in% rownames(mc@mc_fp)) {
			message("gene ", gene_nm, " is not covered/missing from mc footprint")
			next
		}
		fig_fn = sprintf("%s/%s.png", fdir, gene_nm)

		lfp = log2(mc@mc_fp)[gene_nm,]

		if(is.null(reorder_preset)) {
			if(reorder) {
				type_lfp = tapply(lfp, mc@colors, median)
				col_order = names(sort(type_lfp))
			} else {
				ord_lfp = tapply(1:length(lfp), mc@colors, median)
				col_order = names(sort(ord_lfp))
			}
		} else {
			col_order = reorder_preset
		}

		png(fig_fn, width=lane_w*length(col_order), height=height)
#		layout(matrix(c(1,2),nrow=2), heights=c(450,30))
		par(mar = c(0,5,4,3))

		max_lfp = max(lfp)
		min_lfp = min(min(lfp),0)
		max_lfp = max_lfp + (max_lfp-min_lfp)*0.02
		ybot = min_lfp - (max_lfp-min_lfp)/25
		ybot_up = min_lfp - (max_lfp-min_lfp)/70
		min_y = min_lfp - (max_lfp-min_lfp)/80

		plot(0,0, type='n', xlim=c(0,length(col_order)), ylim=c(min_y, max_lfp), xaxt='n', ylab=NA, xlab=NA, main=ifelse(plot_title, gene_nm, ""))
		step = 0
		for(c in col_order) {
			shades = colorRampPalette(c("white", c))(402)[201:402]
			f_mc = mc@colors==c
			x = rank(runif(sum(f_mc))/1000+lfp[f_mc])/(sum(f_mc)+1)
			points(step+x, lfp[f_mc], pch=21, bg=shades[1+floor(x*200)], cex=1.5,lwd=0.5)
			step = step+1
		}
		grids = seq(0,length(col_order),l=length(col_order)+1)
		abline(v=grids, lwd=0.5)
		abline(h=0, lwd=0.5, lty=2)
		rect(xleft=grids[-1]-1, ybottom=ybot, xright=grids[-1],ytop=ybot_up, col=col_order)
#		image(as.matrix(1:length(col_order),nrow=1), col=col_order, yaxt='n', xaxt='n')
		dev.off()
	}
}


#! Generate some fake data...

N.fake<-25000
dat<-read.table('~/Tools/UCSC/mm9.chromSizes',as.is=TRUE)
intdat<-dat[c(1:20,22),]
genome_size<-sum(as.numeric(intdat[,2]))
locs<-sample.int(genome_size,size=N.fake)
chrs<-rep(NA,N.fake)

# break up the chrs
chros<-c(0)
cum<-0
for (i in seq(nrow(intdat))){
    cum<-cum+intdat[i,2]
    chros<-c(chros,cum)
}

get_chro<-function(chros,loc){
    for (i in seq(length(chros)-1)){
        if((chros[i]<loc)&(loc<chros[i+1])){
            return(i)
        }
    }
}

fake.chrs<-sapply(locs,function(x) intdat[get_chro(chros,x),1])
fake.locs<-sapply(locs,function(x) x-chros[get_chro(chros,x)])
fake.ids<-paste("fake_id_",seq(N.fake),sep="")
header<-c("chr","start","end","dREG_id","0","2","5","12.5","25","50","inflation","when_smallest")
fake.X0<-rbinom(N.fake,1,0.5)
fake.X2<-rbinom(N.fake,1,0.5)
fake.X5<-rbinom(N.fake,1,0.5)
fake.X12.5<-rbinom(N.fake,1,0.5)
fake.X25<-rbinom(N.fake,1,0.5)
fake.inflation<-5*rexp(N.fake,rate=4)
fake.X50<-ifelse((fake.X0+fake.X2+fake.X5+fake.X12.5+fake.X25)==0,1,rbinom(N.fake,1,0.5))
fake.dat<-data.frame(fake.chrs,fake.locs,fake.locs+1+ceiling(1000*rexp(N.fake,rate=1.5)),fake.ids,fake.X0,fake.X2,fake.X5,fake.X12.5,fake.X25,fake.X50,fake.inflation,rep("X0",N.fake))
names(fake.dat)<-header
write.table(fake.dat,file="fake_uniq.bed",row.names=F,col.names=T,quote=F,sep="\t")


readcube <- function(fname, drpcat=NULL, flatten=TRUE) {
    require(FITSio)

    ff <- file(fname, "rb")
    hd0 <- parseHdr(readFITSheader(ff))
    versdrp <- hd0[grep("VERSDRP3", hd0)+1]
    mangaid <- hd0[grep("MANGAID", hd0)+1]
    plateifu <- hd0[grep("PLATEIFU", hd0)+1]
    ra <- as.numeric(hd0[grep("IFURA", hd0)+1])
    dec <- as.numeric(hd0[grep("IFUDEC", hd0)+1])
    l <- as.numeric(hd0[grep("IFUGLON", hd0)+1])
    b <- as.numeric(hd0[grep("IFUGLAT", hd0)+1])
    ebv <- as.numeric(hd0[grep("EBVGAL", hd0)+1])
    hd0 <- parseHdr(readFITSheader(ff))
    cra <- as.numeric(hd0[grep("CRVAL1", hd0)+1])
    cdec <- as.numeric(hd0[grep("CRVAL2", hd0)+1])
    cpix1 <- as.numeric(hd0[grep("CRPIX1", hd0)+1])
    cpix2 <- as.numeric(hd0[grep("CRPIX2", hd0)+1])
    cd1 <- as.numeric(hd0[grep("CD1_1", hd0)+1])
    cd2 <- as.numeric(hd0[grep("CD2_2", hd0)+1])
    close(ff)

    if (versdrp >= "v2_4_3") {
      hdu_lambda <- 6
      hdu_gimg <- 12
      hdu_rimg <- 13
      hdu_iimg <- 14
      hdu_zimg <- 15
    } else {
      hdu_lambda <- 4
      hdu_gimg <- 8
      hdu_rimg <- 9
      hdu_iimg <- 10
      hdu_zimg <- 11
    }

    flux <- readFITS(fname, hdu=1)$imDat
    ivar <- readFITS(fname, hdu=2)$imDat
    mask <- readFITS(fname, hdu=3)$imDat
    lambda <- readFITS(fname, hdu=hdu_lambda)$imDat
    ivar[ivar <= 0] <- NA
    ivar[mask >= 1024] <- NA
    flux[is.na(ivar)] <- NA
    extc <- elaw(lambda, ebv)
    nx <- dim(flux)[1]
    ny <- dim(flux)[2]
    nl <- dim(flux)[3]
    for (ix in 1:nx) {
        for (iy in 1:ny) {
            flux[ix,iy,] <- flux[ix,iy,]*extc
            ivar[ix,iy,] <- ivar[ix,iy,]/extc^2
        }
    }
    snr <- apply(sqrt(pmax(flux,0)^2*ivar), c(1,2), median, na.rm=TRUE)
    xpos <- (1:nx-cpix1)*cd1
    ypos <- (1:ny-cpix2)*cd2
    phi <- function(x,y) atan2(-y, x)
    rho <- function(x,y) sqrt(x^2 + y^2)
    long <- outer(xpos, ypos, phi)
    lat <- atan(180/pi/outer(xpos, ypos, rho))
    dec.f <- 180/pi*asin(sin(lat)*sin(cdec*pi/180) - cos(lat)*cos(long)*cos(cdec*pi/180))
    ra.f <- cra + 180/pi*atan2(cos(lat)*sin(long),
                               sin(lat)*cos(cdec*pi/180) + cos(lat)*cos(long)*sin(cdec*pi/180))
    gimg <- readFITS(fname, hdu=hdu_gimg)$imDat*elaw(4640.4,ebv)
    rimg <- readFITS(fname, hdu=hdu_rimg)$imDat*elaw(6122.3,ebv)
    iimg <- readFITS(fname, hdu=hdu_iimg)$imDat*elaw(7439.5,ebv)
    zimg <- readFITS(fname, hdu=hdu_zimg)$imDat*elaw(8897.1,ebv)
    if (!is.null(drpcat)) {
        ind <- which(drpcat$plateifu == plateifu)
        z <- drpcat$nsa_z[ind]
        zdist <- drpcat$nsa_zdist[ind]
    } else {
        z <- zdist <- NA
    }
    if (flatten) {
      fn <- function(x) all(is.na(x))

      hasdata <- as.vector(!apply(flux, c(1,2), fn))
      nxy <- length(which(hasdata))

      xy <- expand.grid(xpos, ypos)
      xpos <- xy[hasdata,1]
      ypos <- xy[hasdata,2]

      ra.f <- as.vector(ra.f)[hasdata]
      dec.f <- as.vector(dec.f)[hasdata]

      flux <- matrix(flux[hasdata], nrow=nxy)
      ivar <- matrix(ivar[hasdata], nrow=nxy)
      mask <- matrix(mask[hasdata], nrow=nxy)

      snr <- as.vector(snr)[hasdata]
      gimg <- as.vector(gimg)[hasdata]
      rimg <- as.vector(rimg)[hasdata]
      iimg <- as.vector(iimg)[hasdata]
      zimg <- as.vector(zimg)[hasdata]
    }
    list(meta=list(mangaid=mangaid, plateifu=plateifu, versdrp=versdrp,
                   ra=ra, dec=dec, l=l, b=b,
                   ebv=ebv, z=z, zdist=zdist, cpix=c(cpix1, cpix2)),
        xpos= -3600 * xpos, ypos=3600 * ypos,
        lambda=lambda, ra.f=ra.f, dec.f=dec.f,
        flux=flux, ivar=ivar, mask=mask, snr=snr,
        gimg=gimg, rimg=rimg, iimg=iimg, zimg=zimg)
}

readrss <- function(fname, drpcat=NULL, ndither=3) {
    require(FITSio)

    ff <- file(fname, "rb")
    hd0 <- parseHdr(readFITSheader(ff))
    versdrp <- hd0[grep("VERSDRP3", hd0)+1]
    mangaid <- hd0[grep("MANGAID", hd0)+1]
    plateifu <- hd0[grep("PLATEIFU", hd0)+1]
    nexp <- as.numeric(hd0[grep("NEXP", hd0)+1])
    ra <- as.numeric(hd0[grep("IFURA", hd0)+1])
    dec <- as.numeric(hd0[grep("IFUDEC", hd0)+1])
    l <- as.numeric(hd0[grep("IFUGLON", hd0)+1])
    b <- as.numeric(hd0[grep("IFUGLAT", hd0)+1])
    ebv <- as.numeric(hd0[grep("EBVGAL", hd0)+1])
    close(ff)

    if (versdrp >= "v2_4_3") {
      hdu_lambda <- 6
      hdu_xpos <- 12
      hdu_ypos <- 13
    } else {
      hdu_lambda <- 5
      hdu_xpos <- 9
      hdu_ypos <- 10
    }

    flux <- readFITS(fname, hdu=1)$imDat
    ivar <- readFITS(fname, hdu=2)$imDat
    mask <- readFITS(fname, hdu=3)$imDat
    lambda <- as.vector(readFITS(fname, hdu=hdu_lambda)$imDat)
    xpos <- readFITS(fname, hdu=hdu_xpos)$imDat
    ypos <- readFITS(fname, hdu=hdu_ypos)$imDat
    xpos <- apply(xpos, 2, mean)
    ypos <- apply(ypos, 2, mean)
    ivar[ivar <= 0] <- NA
    ivar[mask >= 1024] <- NA
    flux[is.na(ivar)] <- NA
    extc <- elaw(lambda, ebv)
    flux <- flux*extc
    ivar <- ivar/extc^2
    nl <- nrow(flux)
    ns <- nexp/ndither
    npos <- ncol(flux)/ns
    xy <- data.frame(x=xpos, y=ypos)
    txy <- SearchTrees::createTree(xy)
    neighbors <- as.vector(SearchTrees::knnLookup(txy, newdat=xy[1:npos,], k=ns))
    flux <- flux[,neighbors]
    ivar <- ivar[,neighbors]
    snr <- apply(sqrt(pmax(flux,0)^2*ivar), 2, median, na.rm=TRUE)
    flux <- array(t(flux), dim=c(npos, ns, nl))
    ivar <- array(t(ivar), dim=c(npos, ns, nl))
    snr <- matrix(snr, npos, ns)
    xpos <- matrix(xpos[neighbors], npos, ns)
    ypos <- matrix(ypos[neighbors], npos, ns)
    if (!is.null(drpcat)) {
        ind <- which(drpcat$plateifu == plateifu)
        z <- drpcat$nsa_z[ind]
        zdist <- drpcat$nsa_zdist[ind]
    } else {
        z <- zdist <- NA
    }
    list(meta=list(mangaid=mangaid, plateifu=plateifu, versdrp=versdrp,
                   nexp=nexp, ra=ra, dec=dec, l=l, b=b,
                   ebv=ebv, z=z, zdist=zdist),
                   lambda=lambda, flux=flux, ivar=ivar, snr=snr,
                   xpos=xpos, ypos=ypos)
}

stackrss <- function(gdat) {
    meta <- gdat$meta
    ivar <- apply(gdat$ivar, c(1,3), sum, na.rm=TRUE)
    ivar[ivar <= 0] <- NA
    flux <- apply(gdat$flux*gdat$ivar, c(1,3), sum, na.rm=TRUE)/ivar
    snr <- apply(sqrt(pmax(flux,0)^2*ivar), 1, median, na.rm=TRUE)
    xpos <- rowMeans(gdat$xpos)
    ypos <- rowMeans(gdat$ypos)
    dec.f <- meta$dec + ypos/3600
    ra.f <- meta$ra - xpos/3600/cos(dec.f*pi/180)
    list(meta=meta, lambda=gdat$lambda, flux=flux, ivar=ivar, snr=snr,
         xpos=xpos, ypos=ypos, ra.f=ra.f, dec.f=dec.f)
}


#' pvap
#'
#' Vapour pressure estimate from relative humidity.
#'
#' @param t numeric Air temperature in degC.
#' @param rh numeric Relative humidity in percentage.
#' @return vapour pressure in hPa.
#'
#'
#' @author Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @keywords  vapour pressure
#'
#' @export
#'
#'
#'
#'

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


# 3. faza: Izdelava zemljevida

# Najprej je treba naloziti paketa za delo z zemljevidi.
library(sp)
library(maptools)
library(rgeos)
gpclibPermit()

source("lib/uvozi.zemljevid.r")

pdf("slike/drzave_zda.pdf")

# USA1 <- uvozi.zemljevid("http://biogeo.ucdavis.edu/data/gadm2/shp/USA_adm.zip",
#                        "USA", "USA_adm1.shp", mapa = "zemljevidi")

USA <- uvozi.zemljevid("http://audrey.fmf.uni-lj.si/states_21basic.zip",
                          "USA", "states.shp", mapa = "zemljevid")

nocemo <- c("Alaska", "Hawaii", "Puerto Rico", "U.S. Virgin Islands")
states <- USA[!(USA$STATE_NAME %in% nocemo),]

m <- match(states$STATE_NAME, rownames(ZDA))
pop <- ZDA[m,4] # populacija je v 4. stolpcu
n <- 4 # 4 kategorije
q <- quantile(pop, (1:n)/n, na.rm = TRUE)
barve <- topo.colors(n)
plot(states, border = "dimgray", col = barve[sapply(pop, function(x) which(x <= q)[1])])
title( main = "ZDA deljena v skupine glede na populacijo")

legend("bottomleft",
       legend=c("Najvišja populacija", "Visoka populacija", "Nizka populacija", "Najnižja populacija"), col=c("yellow","green","cyan","blue"),
       lty = c("solid", "solid", "solid", "solid"),
       lwd = c(10, 10, 10, 10),
       bg = "white",
       title="Legenda")

#Vrišemo glavna mesta na zemljevid
#Iz datoteke uscapitals.csv sem izvzel določena imena glavnih mest zaradi prenatrpanosti
capitals <- read.csv("podatki//uscapitals_1.csv", row.names = 1)

points(coordinates(capitals[c("long", "lat")]),
       col = "red",
       pch = 10, cex = 0.2)

text(coordinates(capitals[c("long", "lat")]), labels = capitals$capital,
     pos = 1, cex = 0.4, offset = 0.1)

dev.off()


library(assertthat)
library(tictoc)

source("constrained_boosting.r")
source("utilities.r")
source("losses.r")
source("read_write_data.r")
source("data_structures.r")
source("sampling.r")
source("causal_inference_methods.r")

synth_validation<-function(data_src=NULL,N=100,n_trees=100,equal_share_tr_assignment=TRUE,
                           equal_share_tr_assignment_resampling=TRUE){
  assert_that(is.null(data_src)||is.character(data_src))
  assert_integer(N)
  assert_that(is.logical(equal_share_tr_assignment))
  assert_that(is.logical(equal_share_tr_assignment_resampling))

  tic("loading data")
  data<-load_data(data_src,N,equal_share_tr_assignment)
  toc()

  tic("running methods")
  ates<-run_methods(data)
  toc()

  print("ates")
  print(ates)

  synth_effects<-create_synth_effects(ates)

  print("synth_effects")
  print(synth_effects)

  tic("generating synthetic data sets")
  synth_data_sets<-generate_synth_data_sets(data,synth_effects,n_trees,
                                             equal_share_tr_assignment_resampling)
  toc()

  tic("pick method")
  ind_best<-pick_best_method(synth_data_sets,synth_effects)
  toc()

  return (Synth_Validation_Result(ates,ind_best))

}

create_synth_effects<-function(ates){
  assert_that(is.numeric(ates))

  #synth effect parameters
  #probably won't be changed
  y=2
  Q=5

  med<-median(ates)
  ran<-range(ates)
  spread<-ran[2]-ran[1]

  lowest_synth_effect<-med-y*spread
  highest_synth_effect<-med+y*spread

  return (seq(lowest_synth_effect,highest_synth_effect,length.out = Q))
}

generate_synth_data_sets<-function(data,synth_effects,n_trees,equal_share_tr_assignment_resampling){
  assert_that(is(data,"data"))
  assert_that(is.numeric(synth_effects))
  assert_integer(n_trees)
  assert_that(is.logical(equal_share_tr_assignment_resampling))

  synth_data_sets<-vector(mode = "list",length = length(synth_effects))

  for(i in 1:length(synth_data_sets)){
    synth_data_sets[[i]]<-synth_data(data,synth_effects[i],n_trees,equal_share_tr_assignment_resampling)
  }

  return (synth_data_sets)
}

synth_data<-function(data,synth_effect,n_trees,equal_share_tr_assignment_resampling){
  assert_that(is(data,"data"))
  assert_that(is.numeric(synth_effect))
  assert_integer(n_trees)
  assert_that(is.logical(equal_share_tr_assignment_resampling))

  #For now those paramenters will be constant,
  #because I don't plan to do any destinction
  #beyond them in my thesis. Potential changes
  #on max_depth adn min_samples_leaf

  N_samples = 1 #number of samples to be drawn from the synthetic distribution
  max_depth = 3 #  max tree depth
  regularization_par = 2 # regularization parameter
  min_samples_leaf = 5 # minimum number of samples per leaf in each tree
  nfolds=4

  # Cross-validation in order to find the best number of fitting iterations
  test_error<-cross_validate(data,synth_effect,n_trees,
                             max_depth,regularization_par,min_samples_leaf,nfolds)

  n_trees_min_error<-max(get_n_trees_min_error(test_error)-1,1)

  print("n_trees")
  print(n_trees_min_error)

  #fitting the model and finding the conditional means for each (X,W)
  F<-constrained_boost(data,synth_effect,n_trees_min_error,max_depth,regularization_par,min_samples_leaf)

  #finding residuals for the model
  residuals<- neg_grad(data$Y,F[[length(F)]]$observed$`TRUE`)

  return (sample_synthetic_data_sets(data,F,residuals,equal_share_tr_assignment_resampling,N_samples))
}

pick_best_method<-function(synth_data_sets,synth_effects){
  assert_that(is.vector(synth_data_sets))
  assert_that(is.numeric(synth_effects))

  ci_methods<-methods()
  avr_err_method<-c(0)
  n_of_data_sets_per_synth_effect<-length(synth_data_sets[[1]])

  for(i in 1:length(ci_methods)){
    avr_err_method[i]<-0
    for(j in 1:length(synth_effects)){
      error_synth_effect<-0
      for(k in 1:n_of_data_sets_per_synth_effect){
        error_data<-abs(synth_effects[j]-ci_methods[[i]](synth_data_sets[[j]][[k]]))
        error_synth_effect<-error_synth_effect+error_data
      }
      error_synth_effect<-error_synth_effect/n_of_data_sets_per_synth_effect
      avr_err_method[i]<-avr_err_method[i]+error_synth_effect
    }
    avr_err_method[i]<-avr_err_method[i]/length(synth_effects)
  }
  print("avg_error_method")
  print(avr_err_method)
  return (which.min(avr_err_method))
}


plot(diplomanti[,"X2007"], xlab="regije", ylab="stevilo diplomantov",
     main="Diplomanti, leto 2007",pch=20, col="red", type="l")

#na x-osi, bi rada, da mi napiše imena regij


# Sample selection criteria summary ============================================
# how does criteria effect number of individuals eligible for analysis and
# number of events under analysis

    library(RODBC);
    source("S:/0000 - Analysts Shared Resources/r-share/login_box.r");
    login = getLogin();
    sql = odbcConnect('PR_SAIL',login[1],login[2]);
    login = 0
#===============================================================================
q_summary <- "
SELECT * FROM (
    SELECT
        0                            					  AS step,
       'in c20'						 					  AS criteria,
        COUNT(*)                     					  AS n_alf,
        NULL						 					  AS n_event
    FROM
        SAILWMCCV.C19_COHORT20 cc
UNION
    SELECT
        1                            					 AS step,
       'age>18 and event anytime post 2000'				 AS criteria,
        COUNT(*)                     					 AS n_alf,
        SUM(out_myo_pericarditis IS NOT null)            AS n_event
    FROM
        SAILWWMCCV.ccu002_03_cohort_base
UNION
    SELECT
        1                            					 AS step,
       'age>18 and event anytime post 2020'				 AS criteria,
        COUNT(*)                     					 AS n_alf,
        SUM(out_myo_pericarditis IS NOT null)            AS n_event
    FROM
        SAILWWMCCV.ccu002_03_cohort_base
        WHERE out_myo_pericarditis >= '2020-01-01'
UNION
    SELECT
        2                            					 AS step,
        'vaccine records and event post 8th Dec 2020'    AS criteria,
        COUNT(*)                                         AS n_alf,
        SUM(out_any_myo_or_pericarditis IS NOT null)     AS n_event
    FROM
        sailwWMCCV.ccu002_03_cohort_analysis_dose1
--        WHERE out_any_myo_or_pericarditis >= '2020-12-08'
)ORDER BY step ;
"

library(data.table)
t_summary <-
    sqlQuery(sql, q_summary)
    setnames(t_summary, tolower(names(t_summary[1:ncol(t_summary)])))
t_summary <-
    t_summary  %>%
    arrange(step) %>%
    mutate(
        diff_alf = n_alf - lag(n_alf),
        pdiff_alf = n_alf / first(n_alf) * 100,
        .after = n_alf
    ) %>%
    mutate(
        diff_event = n_event - lag(n_event),
        pdiff_event = n_event / first(n_event) * 100,
        .after = n_event
    )

write_csv(
    t_summary,
    file = "P:/torabif/workspace/CCU0002-03/results/t_sample_selection_summary.csv"
)


# .hlpr_print_cor ----
.hlpr_print_cor <- function(object, digits = 2, stars = TRUE, html = FALSE) {
  nums <- sapply(as.data.frame(object), is.numeric)

  # Find attributes
  p <- attributes(object)

  if ("stars" %in% names(p)) {
    stars <- p$stars
  }

  # Significance
  type <- names(p)[names(p) %in% c("BF", "pd", "p")][1]
  p <- p[[type]]

  if (!is.null(p)) {
    if (type == "p") {
      p[, nums] <- sapply(p[, nums], parameters::format_p, stars_only = TRUE)
    } else if (type == "pd") {
      p[, nums] <- sapply(p[, nums], parameters::format_pd, stars_only = TRUE)
    } else if (type == "BF") {
      p[, nums] <- sapply(p[, nums], parameters::format_bf, stars_only = TRUE)
    }

    # Round and eventually add stars
    object[, nums] <- sapply(as.data.frame(object)[, nums], insight::format_value, digits = digits)
    if (stars) {
      object[, nums] <- paste0(as.matrix(as.data.frame(object)[, nums]), as.matrix(p[, nums]))
    }
  } else {
    object[, nums] <- sapply(as.data.frame(object)[, nums], insight::format_value, digits = digits)
  }

  if (html) {
    out <- stargazer::stargazer(object, type = "html", summary = FALSE, rownames = FALSE)
    out <- gsub("\\* ", "*", out)
    out <- cat(out, sep = "\n")
    return(out)
  } else {
    cat(insight::format_table(object))
  }
}


base_datos <- read.csv("../base_data/resultAnaliticDataCsv.csv")
dataCleanScoreEmotionDay = base_datos[!is.na(base_datos$scoreEmotionDay),]
dates = unique(dataCleanScoreEmotionDay$fechas)
for (date in dates){
    titulo = date
    resulDay = dataCleanScoreEmotionDay[dataCleanScoreEmotionDay$fechas ==  date,]
    png(file = paste("../public/",titulo, ".png"))
    plot(resulDay$scoreWorkDay,resulDay$scoreEmotionDay)
    dev.off()
}

titulo = 'todo'
png(file = paste("../public/",titulo, ".png"))
plot(dataCleanScoreEmotionDay$scoreEmotionDay,dataCleanScoreEmotionDay$scoreWorkDay)
abline(lm(dataCleanScoreEmotionDay$scoreWorkDay ~ dataCleanScoreEmotionDay$scoreEmotionDay))
correlacion <- cor(dataCleanScoreEmotionDay$scoreEmotionDay,dataCleanScoreEmotionDay$scoreWorkDay)
legend("bottomleft",col=c(correlacion),legend =c(correlacion), lwd=3, bty = "n")
dev.off()

some<-function(datos) {
    todos = c(FALSE);
    for(d in datos){
        if(d != 0){
            todos[1]= TRUE
        }
    }
    todos[1]
}
peoples = unique(dataCleanScoreEmotionDay$name)
for (people in peoples){
    titulo = people
    resulPeople = dataCleanScoreEmotionDay[dataCleanScoreEmotionDay$name ==  people,]
    png(file = paste("../public/",titulo, ".png"))
    print('andando')
    plot(resulPeople$scoreEmotionDay,resulPeople$scoreWorkDay ,main=paste(titulo))
    if( some(resulPeople$scoreWorkDay ) && some(resulPeople$scoreEmotionDay) ){
        abline(lm(resulPeople$scoreWorkDay ~ resulPeople$scoreEmotionDay))
        correlacion <- cor(resulPeople$scoreEmotionDay,resulPeople$scoreWorkDay)
        legend("bottomleft",col=c(correlacion),legend =c(correlacion), lwd=3, bty = "n")
        print(people)
        print(correlacion)
    }
    dev.off()
}
titulo = 'velas_workDay'
png(file = paste("../public/",titulo, ".png"))
boxplot(dataCleanScoreEmotionDay$scoreWorkDay)
dev.off()
titulo = 'velas_scoreEmotionDay'
png(file = paste("../public/",titulo, ".png"))
boxplot(dataCleanScoreEmotionDay$scoreEmotionDay)
dev.off()


source("common.r")

df <- read.csv("../results/idempotence.csv")
df$Time <- df$Time / 1000

df <- ddply(df, c("Name"), summarise,
            Mean = mean(Time),
            Trials = length(Time),
            Sd = sd(Time),
            Se = Sd / sqrt(Trials))

plot <- ggplot(df, aes(x=Name,y=Mean)) +
  mytheme() +
  theme(legend.position = "none",
        axis.text.x=element_text(angle=50, vjust=0.5)) +
  geom_bar(stat="identity",position="dodge", fill="blue") +
  geom_errorbar(aes(ymin=Mean-Se,ymax=Mean+Se,width=.4), position=position_dodge(0.9)) +
  labs(x = "Benchmark", y = "Time (s)")
mysave("../results/idempotence.pdf", plot)


#XYtrace improvements
# this function needs regional selection
# there should be two options for this
# 1. Self selection
# 2. regional selection

# Self selection
#open and name all windows
dat<-RD.170104.22.m.p1
img<-dat$img1
cols<-"red"

dev.new(height=4,width=12)
trace.window<-dev.cur()

dev.new(width=8, height=8)
pic.window<-dev.cur()

dev.new(height=8,width=12)
lines.window<-dev.cur()

#plot image in the window
if(is.null(img)){img<-dat$img1}
img.dim.x<-dim(img)[1]
img.dim.y<-dim(img)[2]
dev.set(which=pic.window)
par(mar=c(0,0,0,0))
plot(0, 0, xlim=c(0,img.dim.x),ylim=c(img.dim.y,0),xaxs="i", yaxs="i",col=cols,pch=".")
if(!is.null(img)){
	rasterImage(img, 0, img.dim.y, img.dim.x, 0)
}
#points(cell.coor[,1],cell.coor[,2],col=cols,pch=0)}

x.sel<-locator(n=2, type="l", col="Red")$x
y.sel<-locator(n=2, type="l", col="Red")$y

rect(x.sel[1],y.sel[2],x.sel[2],y.sel[1])

# now i need to clsoe the window and open a new one with the same type of selection
x.size<-abs(x.sel[1]-x.sel[2])
y.size<-abs(y.sel[1]-y.sel[2])

#width vs height ratio
w.v.h<-y.size/x.size
h<-8*w.v.h
dev.off()
dev.new(width=8, height=h)
pic.window<-dev.cur()

plot(0, 0, xlim=c(x.sel[1],x.sel[2]),ylim=c(y.sel[1],y.sel[2]),xaxs="i", yaxs="i",col=cols,pch=".")
rasterImage(img[x.sel[1]:x.sel[2],y.sel[1]:y.sel[2], ], x.sel[1], y.sel[2], x.sel[2], y.sel[1])

if(is.null(img)){img<-dat$img1}
img.dim.x<-dim(img)[1]
img.dim.y<-dim(img)[2]

if(is.null(img)){img<-dat$img1}
img.dim.x<-dim(img)[1]
img.dim.y<-dim(img)[2]
dev.set(which=pic.)
par(mar=c(0,0,0,0))

plot(0, 0, xlim=c(0,img.dim.x),ylim=c(img.dim.y,0),xaxs="i", yaxs="i",col=cols,pch=".")
if(!is.null(img)){
	rasterImage(img, 0, img.dim.y, img.dim.x, 0)
	points(cell.coor[,1],cell.coor[,2],col=cols,pch=0)
	}
else{
points(cell.coor[,1],cell.coor[,2], col=cols, cex=dat$c.dat[,area]/200)
points(cell.coor[,1],cell.coor[,2],col=cols, pch=4)}

# working with
dat<-RD.170104.22.m.p1

# Function allows for selection and deselection of cells to build stacked traces
XYtrace <- function(dat, cell=NULL, img=NULL, cols=NULL, labs=F, y.var=T)
{
	graphics.off()
	x.coor<-grep("\\.x",names(dat$c.dat), value=T, ignore.case=T)
	if(length(x.coor)>1){x.coor<-"center.x"}
	y.coor<-grep("\\.y",names(dat$c.dat), value=T, ignore.case=T)
	if(length(x.coor)>1){y.coor<-"center.y"}
	area<-grep("area",names(dat$c.dat), value=T, ignore.case=T)

	lab1<-grep("cgrp",names(dat$c.dat), value=T, ignore.case=T)
	if(length(lab1)==0){lab1<-grep("gfp.1",names(dat$c.dat), value=T, ignore.case=T)}

	lab1.1<-grep("cgrp",names(dat$c.dat), value=T, ignore.case=T)
	if(length(lab1.1)==0){lab1.1<-grep("gfp.2",names(dat$c.dat), value=T, ignore.case=T)}

	lab2<-grep("ib4",names(dat$c.dat), value=T, ignore.case=T)
	if(length(lab2)==0){lab2<-grep("tritc",names(dat$c.dat), value=T, ignore.case=T)}

	if(is.null(cell)){cell<-row.names(dat$c.dat)}
	else{cell<-cell}
	cell.coor<-dat$c.dat[cell,c(x.coor, y.coor)]

	# select the names of the collumns containing coordinates
	levs <- unique(dat$w.dat[,"wr1"])
	levs<-setdiff(levs, "")
	if(labs==TRUE){
	if(is.null(cols)){cols="orangered1"} else{cols=cols}}
	pch=16

	dev.new(height=4,width=12)
	trace.window<-dev.cur()

	dev.new(width=8, height=8)
	pic.window<-dev.cur()

	dev.new(height=8,width=12)
	lines.window<-dev.cur()

	lmain<-"XY ROI"

	if(is.null(img)){img<-dat$img1}
	img.dim.x<-dim(img)[1]
	img.dim.y<-dim(img)[2]
	dev.set(dev.list()[2])
	par(mar=c(0,0,0,0))
	plot(0, 0, xlim=c(0,img.dim.x),ylim=c(img.dim.y,0),xaxs="i", yaxs="i",col=cols,pch=".")
	if(!is.null(img)){rasterImage(img, 0, img.dim.y, img.dim.x, 0);points(cell.coor[,1],cell.coor[,2],col=cols,pch=0)}
	else{
	points(cell.coor[,1],cell.coor[,2], col=cols, cex=dat$c.dat[,area]/200)
	points(cell.coor[,1],cell.coor[,2],col=cols, pch=4)}

	i <- identify(cell.coor[,1],cell.coor[,2],n=1,plot=F, col=NA, tolerance=0.05)
	i.names<-row.names(dat$c.dat[cell,])[i]
	while(length(i) > 0)
	{	#selected name of cell
		s.names <- row.names(dat$c.dat[cell,])[i]
		dev.set(dev.list()[1])
		if(y.var){PeakFunc6(dat,s.names, Plotit.both=F)}
		else{PeakFunc5(dat,s.names, Plotit.both=T)}

		dev.set(dev.list()[2])
		# If a cell is selected, that has already been selected,
		# then remove that cell from the list
		if(length(intersect(i.names,s.names))==1){
			i.names<-setdiff(i.names,s.names)
			points(cell.coor[s.names,1],cell.coor[s.names,2],col="gray70",pch=0,cex=2.4)
			points(cell.coor[i.names,1],cell.coor[i.names,2],col="red",pch=0,cex=2.4)
		}
		# If it han't been selected, then add it to the list
		else{i.names<-union(i.names,s.names)
		points(cell.coor[i.names,1],cell.coor[i.names,2],col="red",pch=0,cex=2.4)}

		if(length(i.names)>=1){
			dev.set(dev.list()[3])
			LinesEvery.5(dat,m.names=i.names, plot.new=F, img=img, cols="black",sf=.2)}
			dev.set(dev.list()[2])
			i <- identify(cell.coor[,1],cell.coor[,2],labels=dat$c.dat[cell,1],n=1,plot=T, pch=0,col="white", tolerance=0.05)
		}
	dev.off()
	graphics.off()
	return(row.names(dat$c.dat[i.names,]))

}


# ##########################################################################################
# for the installation of the required packages, use:
# install.packages(c('e1071','rrcov','mvpart','FNN','CORElearn', 'R.utils', 'infotheo'))
#
# usage:
# Rscript meta-features-1.0.R <dataset_filename> <meta-features_filename>
# ##########################################################################################

library(e1071)
library(rrcov)
library(mvpart)
library(FNN)
library(CORElearn)
library(R.utils)
library(infotheo)

n_col <- function(x) {
    dim(x)[2]
}

n_row <- function(x) {
    dim(x)[1]
}

get_class_indx <- function(data) {
    length(data)
}

get_col_name <- function(data, col) {
    names(data)[col]
}

get_att_names <- function(data) {
    names(data)[-get_class_indx(data)]
}

get_class_name <- function(data) {
    get_col_name(data, get_class_indx(data))
}

get_num_att <- function(data) {
    length(data) - 1
}

get_classes <- function(data) {
    levels(data[,get_class_indx(data)])
}

get_column_of_class <- function(data, column, class) {
    class_index <- get_class_indx(data)
    m <- data[class_index]==class
    data[,column][m]
}

get_att_data <- function(data) {
    class_index <- get_class_indx(data)
    data[-class_index]
}

get_class_data <- function(data) {
    data[get_class_indx(data)]
}

get_num_classes <- function(data) {
    length(get_classes(data))
}

get_num_numeric_att <- function(data) {
    att_data <- get_att_data(data)
    if(is.factor(att_data)) {
        n <- 0
    } else if(is.numeric(att_data)) {
        n <- 1
    } else {
        n <- 0
        for(att in 1:n_col(att_data)) {
            n <- n + is.numeric(att_data[,att])
        }
    }
    n
}

get_num_nominal_att <- function(data) {
    get_num_att(data) - get_num_numeric_att(data)
}

get_num_samples <- function(data) {
    n_row(data)
}

normalize <- function(data) {
    data_2 <- data.frame(data)
    num_att <- get_num_att(data_2)
    for(col in 1:num_att) {
        if(is.numeric(data[,col])) {
            min_v = min(data_2[col])
            max_v = max(data_2[col])
            d <- (max_v - min_v)
            if(is.na(d)) { # -- CGC: handling NAs as we do d == 0, will keep NA below
            	d <- 0
            }
            if(d == 0) {
                d <- 1.0
            }
            data_2[col] <- (data_2[col] - min_v) / d
        }
    }
    data_2
}

replace_nominal_column <- function(column, type=1) {
    column <- as.factor(column)
    symbols <- levels(column)
    result <- {}
    for (i in 1:(length(symbols)-type)) {
        result <- cbind(result, as.double(column == symbols[i]))
    }
    result
}

replace_nominal <- function(data, skip=numeric(0)) {
    result <- {}
    for(i in 1:n_col(data)) {
        column <- data[,i]
        if(is.numeric(column) || i %in% skip) {
            if(is.numeric(column)) {
                result <- cbind(result, column)
            } else {
                result <- cbind(result, data[i])
            }
        } else {
            result <- cbind(result, replace_nominal_column(column))
        }
    }
    data.frame(result)
}

replace_nominal_att <- function(data) {
    replace_nominal(data, skip=get_class_indx(data))
}

##########################################################################
##  Feature Selection for Meta-learning                                 ##
##  Alexandros Kalousis and Melanie Hilario                             ##
##  Advances in Knowledge Discovery and Data Mining                     ##
##  Lecture Notes in Computer Science, 2001, Volume 2035/2001, 222-233  ##
##  DOI: 10.1007/3-540-45357-1_26                                       ##
##########################################################################

get_symbol_stats <- function(data) {
    n <- numeric(0)
    for(i in 1:n_col(data)) {
        column <- data[,i]
        if(!is.numeric(column)) {
            n <- c(n, length(levels(as.factor(column))))
        }
    }
    result <- get_min_max_mean_sd(n, "symbols")
    result["symbols_sum"] <- sum(n)
    result
}

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

get_single_normalized_entropies <- function(data) {
    m <- numeric(0)
    att_data <- get_att_data(data)
    for(i in 1:n_col(att_data)) {
        m[paste("att_entr", i, sep="_")] <- get_normalized_entropy(att_data[i])
    }
    m
}

get_single_mutual_information <- function(data) {
    m <- numeric(0)
    att_data <- get_att_data(data)
    labels <- get_class_data(data)
    for(i in 1:n_col(att_data)) {
        m[paste("att_mut_inf", i, sep="_")] <- get_mutual_information_column(att_data[i], labels)
    }
    m
}

##########################################################################
##  Meta-data: Characterization of Input Features for Meta-learning     ##
##  Ciro Castiello, Giovanna Castellano and Anna Maria Fanelli          ##
##  Modeling Decisions for Artificial Intelligence                      ##
##  Lecture Notes in Computer Science, 2005, Volume 3558/2005, 457-468  ##
##  DOI: 10.1007/11526018_45                                            ##
##########################################################################

get_entropy <- function(column, method="ML") {
    column <- column[,1]
    if(is.numeric(column)) {
        column <- infotheo::discretize(column, disc="equalwidth")
    }
    infotheo::entropy(column)
}

get_normalized_entropy <- function(column) {
    column <- column[,1]
    if(is.numeric(column)) {
        column <- infotheo::discretize(column, disc="equalwidth")
        n <- round(sqrt(dim(column)[1]))     # -- number of bins = square root of number of samples --
    }
    else {
        n <- length(levels(as.factor(column)))
        if(n==1) { # -- CGC: only one target class value / unlikely but happens in Bool space, NormEnt = Ent in this case
        	n <- 2
    	}
    }
    infotheo::entropy(column) / log(n)
}

get_avg <- function(data, f) {
    att_data <- get_att_data(data)
    avg <- 0.0
    for(i in 1:n_col(att_data)) {
        avg <- avg + f(att_data[i])
    }
    avg / n_col(att_data)
}

get_avg_with_labels <- function(data, f) {
    att_data <- get_att_data(data)
    labels <- get_class_data(data)
    avg <- 0.0
    for(i in 1:n_col(att_data)) {
        avg <- avg + f(att_data[i], labels)
    }
    avg / n_col(att_data)
}

get_attribute_entropy <- function(data) {
    get_avg(data, get_entropy)
}

get_normalized_attribute_entropy <- function(data) {
    get_avg(data, get_normalized_entropy)
}

get_class_entropy <- function(data) {
    infotheo::entropy(get_class_data(data))
}

get_normalized_class_entropy <- function(data) {
    get_normalized_entropy(get_class_data(data))
}

get_joint_entropy_column <- function(column, labels) {
    column <- column[,1]
    labels <- labels[,1]
    if(is.numeric(column)) {
        column <- infotheo::discretize(column, disc="equalwidth")
    }
    infotheo::entropy(paste(column, labels))
}

get_joint_entropy <- function(data) {
    get_avg_with_labels(data, get_joint_entropy_column)
}

get_mutual_information_column <- function(column, labels) {
    column <- column[,1]
    labels <- labels[,1]
    if(is.numeric(column)) {
        column <- infotheo::discretize(column, disc="equalwidth")
    }
    infotheo::mutinformation(column, labels)
}

get_mutual_information <- function(data) {
    get_avg_with_labels(data, get_mutual_information_column)
}

get_equivalent_number_of_attributes <- function(data) {
	cl_ent <- get_class_entropy(data)   # -- CGC: did not handle 0/0, Inf/NA/NaN
	mut_info <- get_mutual_information(data)
	if(cl_ent==0) {
		0
	} else if(mut_info==0) {
		1e10
	} else {
		cl_ent / mut_info
	}
#    get_class_entropy(data) / get_mutual_information(data)
}

#Sometimes Inf of course, so is the next one, although never NA

get_noise_signal_ratio <- function(data) {
	mut_info <- get_mutual_information(data)   # -- CGC: did not handle /0, Inf
	if(mut_info==0) {
		1e10
	} else {
		(get_attribute_entropy(data) - get_mutual_information(data)) / mut_info
	}
#    (get_attribute_entropy(data) - get_mutual_information(data)) / get_mutual_information(data)
}

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

get_skewness <- function(data, type=1) {
    num_att <- get_num_att(data)
    classes <- get_classes(data)
    skew <- 0.0
    for(class in classes) {
        s <- 0.0
        n <- 0.0
        for(col in 1:num_att) {
            att_data_class <- get_column_of_class(data, col, class)
            if(is.numeric(att_data_class)) {  # -- skip nominal attributes --
                v <- e1071::skewness(att_data_class, type=type)
                if(!is.nan(v) && !is.na(v)) {  # -- NaN e.g. if the attribute has equal values for one class --
                    s <- s + abs(v)
                    n <- n + 1.0
                }
            }
        }
        if(n > 0.0) { # -- 0 e.g. if one class with only one smaple
            skew <- skew + (s / n)
        }
    }
    skew / (length(classes))
}

get_kurtotis <- function(data, type=1) {
    num_att <- get_num_att(data)
    classes <- get_classes(data)
    kurtosis <- 0.0
    for(class in classes) {
        s <- 0.0
        n <- 0.0
        for(col in 1:num_att) {
            att_data_class <- get_column_of_class(data, col, class)
            if(is.numeric(att_data_class)) {  # -- skip nominal attributes --
                v <- e1071::kurtosis(att_data_class, type=type)
                if(!is.nan(v) && !is.na(v)) {  # -- NaN e.g. if the attribute has equal values for one class --
                    s <- s + v
                    n <- n + 1.0
                }

            }
        }
        if(n > 0.0) { # -- 0 e.g. if one class with only one smaple
            kurtosis <- kurtosis + (s / n)
        }
    }
    (kurtosis / (length(classes))) + 3.0
}

get_cancors <- function(data) {
    att_data <- get_att_data(data)
    preprocess_att_data <- replace_nominal(att_data)
    labels <- get_class_data(data)
    preprocess_labels <- replace_nominal(labels)
 	if(get_num_classes(data)==1) { # -- CGC: only one target class value / unlikely but happens in Bool space
 		if(data[1,get_class_indx(data)]==0) {
 			center = 0.00000000001
 		}
 		else {
 			center = 1.00000000001
 		}
 		cancor(preprocess_att_data, preprocess_labels, TRUE, center)$cor
	}
	else {
    	cancor(preprocess_att_data, preprocess_labels)$cor
    }
}

get_cancor <- function(data, n) {
    m = numeric(0)
    c <- get_cancors(data)[1:n]
    for(i in 1:n) {
        m[paste("cancor",i, sep='_')] <- c[i]
    }
    m
}

get_fracts <- function(data) {
    cancors <- get_cancors(data)
    cancor2 = cancors * cancors
    cs <- cumsum(cancor2)   # -- CGC: avoiding 0/0 which leads to NA, return 0
    if(cs==0) {
    	0
    } else {
    	cs / sum(cancor2)
    }
    #cumsum(cancor2) / sum(cancor2)
}

get_fract <- function(data, n) {
    m = numeric(0)
    c <- get_fracts(data)[1:n]
    for(i in 1:n) {
        m[paste("fract",i, sep='_')] <- c[i]
    }
    m
}

get_abs_cor <- function(data) {
    num_att <- get_num_att(data)
    if(num_att > 1) { # -- correlation between attributes -> one attribute useless
        classes <- get_classes(data)
        sum = 0.0
        n = 0.0
        for(class in classes) {
            for(col1 in 1:num_att) {
                for(col2 in 1:num_att) {
                    if(col1 != col2) {
                        col1_data_class <- get_column_of_class(data, col1, class)
                        col2_data_class <- get_column_of_class(data, col2, class)
                        if(!is.numeric(col1_data_class)) {
                            col1_data_class <- replace_nominal_column(col1_data_class)
                        }
                        if(!is.numeric(col2_data_class)) {
                            col2_data_class <- replace_nominal_column(col2_data_class)
                        }
                        c <- tryCatch(cancor(col1_data_class, col2_data_class)$cor[1], error=function(err) NA)
                        if (!is.na(c)) {
                            sum <- sum + abs(c)
                            n <- n +1
                        }
                    }
                }
            }
        }
        sum / n
    } else {
        0.0
    }
}

get_naive_bayes <- function(data) {
    att_data <- get_att_data(data)
    labels <- get_class_data(data)[,1]
    if(length(levels(labels))==1) { # -- CGC: only one target class value / unlikely but happens in Bool space
    	levels(labels) <- c(0,1)
    }
    model <- naiveBayes(att_data, labels)
    predictions <- predict(model, att_data)
    sum(predictions == labels) / get_num_samples(data)
}

get_linear_discriminant <- function(data) {
    att_data <- get_att_data(data)
    preprocess_att_data <- replace_nominal(att_data)
    labels <- get_class_data(data)[,1]
    model <- tryCatch(LdaClassic(preprocess_att_data, labels), error=function(err) NULL)
	if(is.null(model)) {  # -- CGC: means some vectors are colinear / unlikely but happens in Bool space (did not change this, but catch in measure_landmark_p)
        NA
    } else {
        predictions <- predict(model, preprocess_att_data)@classification
        sum(predictions == labels) / get_num_samples(data)
    }
}

get_min_max_mean_sd <- function(x, name) {
    m <- numeric(0)
    m[paste(name, "min", sep="_")] = min(x)
    m[paste(name, "max", sep="_")] = max(x)
    m[paste(name, "mean", sep="_")] = mean(x)

    s <- sd(x)
    if(is.na(s)) {
        s <- 0
    }
    m[paste(name, "sd", sep="_")] <- s
    m
}

#######################################################################################
##  Decision tree based measures                                                     ##
#######################################################################################
##  Improved Dataset Characterisation for Meta-learning                              ##
##  Yonghong Peng, Peter A. Flach, Carlos Soares and Pavel Brazdil                   ##
##  Lecture Notes in Computer Science, 2002, Volume 2534/2002, 193-208               ##
##  DOI: 10.1007/3-540-36182-0_14                                                    ##
##  [all 15 features]                                                                ##
#######################################################################################
##  A higher-order approach to meta-learning                                         ##
##  H. Bensusan, C. Giraud-Carrier, and C. Kennedy.                                  ##
##  In Proceedings of the ECML'2000 Workshop on Meta- Learning:                      ##
##  Building Automatic Advice Strategies for Model Selection and Method Combination  ##
##  pages 109-117, 2000.                                                             ##
##  [only few features]                                                              ##
#######################################################################################

# Received from Matthias by email on Oct 12, 2012
tree.depth <- function (nodes) {
    depth <- floor(log(nodes, base = 2) + 1e-7)
    as.vector(depth - min(depth))
}

get_tree_properties <- function(data) {
    f <- as.formula(paste(get_class_name(data), "~ ."))
    tree_time <- System$currentTimeMillis();
    model <-mvpart::rpart(f, data = data, method = "class", control=rpart.control(maxcompete=0, maxsurrogate=0))
    tree_time <- System$currentTimeMillis() - tree_time
    leaves = rownames(model$frame[model$frame$var=="<leaf>",])
    n_leaves = length(leaves)
    n_nodes = sum(model$frame$var!="<leaf>")

    branch_lengths = numeric(0)
    for(leaf in leaves) {
        branch_lengths <- c(branch_lengths, length(path.rpart(model, leaf, print.it=FALSE)[[leaf]]))
    }

    att_used = numeric(0)
    for(att in get_att_names(data)) {
        att_used <- c(att_used, sum(model$frame$var==att))
    }

    depths <- tree.depth(as.numeric(row.names(model$frame)))
    level <- numeric(0)
    for(d in 1:max(depths)) {
        level <- c(level, sum(depths==d))
    }

    result <- numeric(0)
    result["nodes"] <- n_nodes
    result["leaves"] <- n_leaves
    result["nodes_per_attribute"] <- n_nodes / get_num_att(data)
    result["nodes_per_instance"] <- n_nodes / get_num_samples(data)
    result["leaf_corrobation"] <- mean(model$frame$n[model$frame$var=="<leaf>"]) / get_num_samples(data)
    result <- c(result, get_min_max_mean_sd(level, "level"))
    result <- c(result, get_min_max_mean_sd(branch_lengths, "branch"))
    result <- c(result, get_min_max_mean_sd(att_used, "attribute"))

    time <- numeric(0)
    time["tree_time"] <- tree_time
    list(result=result, time=time)
}

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

get_decision_stump <- function(data, col) {
    f <- as.formula(paste(get_class_name(data), "~", get_col_name(data, col)))
    model <-mvpart::rpart(f, data = data, method = "class", control=rpart.control(maxdepth=1))
    att_data <- get_att_data(data)
    labels <- get_class_data(data)[,1]
    predictions <- predict(model, att_data, type = "class")
    sum(predictions == labels) / get_num_samples(data)
}

get_decision_stumps <- function(data) {
    v <- numeric(0)
    g <- numeric(0)
    num_att <- get_num_att(data)
    time <- System$currentTimeMillis();
    for(col in 1:num_att) {
        v <- c(v, get_decision_stump(data, col))
        f <- as.formula(paste(get_class_name(data), "~", get_col_name(data, col)))
 		if(get_num_classes(data)==1) { # -- CGC: only one target class value / unlikely but happens in Bool space
 			g <- c(g, 0)
 		}
 		else {
        	g <- c(g, attrEval(f, data, estimator="GainRatio")[1])
        }
    }
    time <- System$currentTimeMillis() - time
    # -- attribute with minimal gain ration --
    #f <- as.formula(paste(get_class_name(data), "~ ."))
    #gainRatios <- attrEval(f, data, estimator="GainRatio")

    result <- get_min_max_mean_sd(v, "stump")
    result['stump_min_gain'] <- v[which.min(g)]
    result['stump_random'] <- v[sample(1:length(v), 1)]
    list(result=result, time=time)
}

get_knn <- function(data, k, cv=TRUE) {
    att_data <- get_att_data(data)
    labels <- get_class_data(data)
    if(cv) {
        predictions <- FNN::knn.cv(att_data, labels[,], k=k, prob=FALSE, algorithm="kd_tree")
    } else {
        predictions <- FNN::knn(att_data, att_data, labels[,], k=k, prob=FALSE, algorithm="kd_tree")
    }
    sum(as.vector(predictions) == labels) / get_num_samples(data)
}

get_knns <- function(data, max_k) {
    result <- numeric(0)
    time <- System$currentTimeMillis()
    for(k in 1:max_k) {
        result[paste("nn", k, sep="_")] = get_knn(data, k)
        gc()
    }
    time <- System$currentTimeMillis() - time
    if(length(result)==1) { # -- CGC: only one value produces NA - set sd to 0 for (meta)metalearning experiment
    	result["nn_sd"] <- 0
    }
    else {
    	result["nn_sd"] <- sd(result)
    }
    list(result=result, time=time)
}

get_class_stats <- function(data) {
    classes <- get_classes(data)
    class_data <- get_class_data(data)
    probs <- numeric(0)
    for(class in classes) {
        probs[class] <- sum(class_data == class) / n_row(data)
    }
    get_min_max_mean_sd(probs, "class_prob")
}

measure_landmark <- function(f, data, param) {
    measure_landmark_p(f, data, NULL)
}

measure_landmark_p <- function(f, data, param) {
    m = numeric(0)
    time <- System$currentTimeMillis()
    if(is.null(param)) {
        result <- f(data)
    } else {
        result <- f(data, param)
    }
    time <- System$currentTimeMillis() - time
    if(is.na(result)) {  # -- CGC: mostly/only applies to LDA(?), do not want NA for either result or time, change to 0 (poor performance) and 1e10 (bad time)
    	result <- 0
    	time <- 1e10
#        time <- NA
    }
    list(result=result, time=time)
}

compute_landmarking <- function(data, data_preprocessed=NULL) {
    if(is.null(data_preprocessed)) {
        data_numeric <- replace_nominal_att(data)
        data_preprocessed <- normalize(data_numeric)
    }
    naive_bayes <- measure_landmark(get_naive_bayes, data)
    lda <- measure_landmark(get_linear_discriminant, data_preprocessed)
    stumps <- get_decision_stumps(data)
    knns <- get_knns(data_preprocessed, 1)

    result <- numeric(0)
    result["naive_bayes"] <- naive_bayes$result
    result["lda"] <- lda$result
    result <- c(result, stumps$result)
    result <- c(result, knns$result)

    time <- numeric(0)
    time["naive_bayes_time"] <- naive_bayes$time
    time["lda_time"] <- lda$time
    time["stump_time"] <- stumps$time
    time["nn_time"] <- knns$time

    list(result=result, time=time)
}

compute_meta_features <- function(data, n) {
    combine(compute_grouped_meta_features(data))
}

combine <- function(x) {
    result <- numeric(0)
    for(name in names(x)) {
        result <- c(result, x[[name]])
    }
    result
}

test_mf <- function(data) {
    print(data)
}

compute_grouped_meta_features <- function(data) {
    total_time <- System$currentTimeMillis()
    data_numeric <- replace_nominal_att(data)
    data_preprocessed <- normalize(data_numeric)

    time <- numeric(0)

    simple <- numeric(0)
    simple_time <- System$currentTimeMillis()
 	if(get_num_classes(data)==1) { # -- CGC: only one target class value / unlikely but happens in Bool space
 		simple['classes'] <- 2
 	}
 	else {
    	simple['classes'] <- get_num_classes(data)
    }
    simple['attributes'] <- get_num_att(data)
    simple['numeric'] <- get_num_numeric_att(data)
    simple['nominal'] <- get_num_nominal_att(data)
    simple['samples'] <- get_num_samples(data)
    simple['dimensionality'] <- simple['attributes'] / simple['samples']
    simple['numeric_rate'] <- simple['numeric'] / simple['attributes']    ## -- Feature Selection for Meta-Learning
    simple['nominal_rate'] <- simple['nominal'] / simple['attributes']    ## -- Feature Selection for Meta-Learning
    simple <- c(simple, get_symbol_stats(data))
    simple <- c(simple, get_class_stats(data))
    simple_time <- System$currentTimeMillis() - simple_time

    statistical <- numeric(0)
    statistical_time <- System$currentTimeMillis()
    statistical['skewness'] <- get_skewness(data)
    statistical['skewness_prep'] <- get_skewness(data_preprocessed)
    statistical['kurtosis'] <- get_kurtotis(data, type=1)
    statistical['kurtosis_prep'] <- get_kurtotis(data_preprocessed, type=1)
    statistical['abs_cor'] <- get_abs_cor(data)
    statistical <- c(statistical, get_cancor(data, 1))
    statistical <- c(statistical, get_fract(data, 1))
    statistical_time <- System$currentTimeMillis() - statistical_time

    inftheo <- numeric(0)
    inftheo_time <- System$currentTimeMillis()
    inftheo['class_entropy'] <- get_class_entropy(data)
    inftheo['normalized_class_entropy'] <- get_normalized_class_entropy(data)
    inftheo['attribute_entropy'] <- get_attribute_entropy(data)
    inftheo['normalized_attribute_entropy'] <- get_normalized_attribute_entropy(data)
    inftheo['joint_entropy'] <- get_joint_entropy(data)
    inftheo['mutual_information'] <- get_mutual_information(data)
    inftheo['equivalent_attributes'] <- get_equivalent_number_of_attributes(data)
    inftheo['noise_signal_ratio'] <- get_noise_signal_ratio(data)

    inftheo_time <- System$currentTimeMillis() - inftheo_time

    modelbased <- get_tree_properties(data)
    time <- c(time, modelbased$time)
    modelbased <- modelbased$result

    landmarking <- compute_landmarking(data, data_preprocessed=data_preprocessed)
    time <- c(time, landmarking$time)
    landmarking <- landmarking$result

    total_time <- System$currentTimeMillis() - total_time
    time['simple_time'] <- simple_time
    time['statistical_time'] <- statistical_time
    time['inftheo_time'] <- inftheo_time
    time['total_time'] <- total_time

    list(simple=simple, statistical=statistical, inftheo=inftheo, modelbased=modelbased, landmarking=landmarking, time=time)
}

read <- function(filename) {
    data<-read.csv(filename, header=FALSE, sep=' ')
    m <- numeric(0)
    for(i in 1:get_num_att(data)) {
        m <- c(m, NA)
    }
    m <- c(m, "factor")
    read.csv(filename, header=FALSE, sep=' ', colClasses=m)
}

write_meta_features <- function(x, filename) {
    write.table(t(x), file=filename, row.names=FALSE, quote=FALSE)
}

args = base::commandArgs(TRUE)  # -- 'base::' needed because R.utils overwrites the function --

filename = args[1]
outfile = args[2]
n = 0
mf <- compute_meta_features(read(filename), n)
write_meta_features(mf, outfile)


#' Plot natural mortality rate
#'
#' Plot mean natural mortality rate as line, colored dots show annual values (if differ from mean).
#' @param asap name of the variable that read in the asap.rdat file
#' @param save.plots save individual plots
#' @param od output directory for plots and csv files
#' @param plotf type of plot to save
#' @export

PlotM <- function(asap,save.plots,od,plotf){
  ages <- seq(1,asap$parms$nages)
  meanM <- apply(asap$M,2,mean)
  nyears <- asap$parms$nyears
  yr.col <- rainbow(nyears, start = 0, end = 0.75)

  plot(ages,meanM,type='l',lwd=2,xlab="Age",ylab="Natural Mortality Rate",
       ylim=c(0,1.1*max(asap$M)))

  if (length(unique(asap$M.age)) > asap$parms$nages) {
    for (i in 1:length(asap$M[,1])){
      points(jitter(ages, factor=0.25), asap$M[i,],col=yr.col[i])
    }
    legend('top', horiz=T, legend=c("First Year", "Last Year"), pch=c(1,1),
           col=c(yr.col[1], yr.col[nyears])  )
  } # end if-test for time varying M
  title(main="M", outer=F)
  if (save.plots) savePlot(paste0(od, "M.", plotf), type=plotf)
  return()
}


##FbF-Gráficos=group
##Layer=vector
##Columna=Field Layer
##Nivel=Field Layer
##Salida=Output file html

#Librerias
library(htmlwidgets)
library(leaflet)
library(leaflet.extras)
# Parametros
input = Layer
columna = Columna
nombre = Nivel
#MapaWeb
pal <- colorBin(
  palette = "viridis",
  domain = c(min(input[[columna]]),max(input[[columna]])),
  n = 5)

mapaweb = input %>%
  leaflet() %>%
  addProviderTiles(
    provider ="OpenStreetMap",
    group = "OSM") %>%
  addProviderTiles(
    provider = "Esri.WorldImagery",
    group = "Satelital") %>%
  addLayersControl(baseGroups = c("OSM","Satelital"),) %>%
  addPolygons(
    fillColor =~pal(input[[columna]]),
    color = "black",
    weight = 1,
    fillOpacity = 0.9,
    popup = paste0(
      "<b>El valor de: </b>",
      input[[nombre]],"<br>",
      input[[columna]])
    ) %>%
  addLegend("bottomright",
            pal = pal,
            values = input[[columna]],
            title = columna,
            opacity = 1
            ) %>%
  addResetMapButton() %>%
  addControlGPS()
saveWidget(mapaweb,Salida)


# Author: Richard Glennie
# 2016
#
# Running a distance sampling simulation where animals move

library(Rcpp)
library(RcppArmadillo)
sourceCpp("simds.cc")

# set simulation parameters
population.size <- 100
region.size <- c(1000, 1000)
# simulation assumes all lines are randomly placed
# and have same length/width
line.size <- c(60, 1000)
# behaviour = 0 (no movement), 1 (linear movement constant speed, random direction),
# 2 (OU home-range movement)
behaviour <- 0
observer.speed <- 1
see.behind <- TRUE
num.transects <- 50
# parameter contains (c, d) detection parameters for continuous hazard
# (see p338 Advanced Distance Sampling)
# Afterward, parameter contains movement parameters:
# behaviour = 0 (no parameters added), 1 (add animal speed), 2 (add c, tau parameters (see Gillespie et al (1996) for parameterisation)
parameter <- c(100, 3, 1)

# run simulation
sim.dat <- c(population.size, region.size, line.size, behaviour, observer.speed, num.transects, see.behind)

num.simulations <- 10
dt <- 1

system.time(Simulate(num.simulations, parameter, sim.dat, dt))


rm(list=ls())

require(PBSadmb)

library(lattice)
library(RColorBrewer)
library(doBy)

reposDir    <- "/Users/jim/_mymods/amak/examples/bogo/"
codePath    <- file.path(reposDir,"R")
inputPath   <- reposDir
outputPath  <- file.path(reposDir,"arc/")
resultPath  <- file.path(reposDir,"results/")
fndir<-"/users/jim/Dropbox/R_common/"
outdir="/Users/jim/_mymods/AMAK/examples/bogo/"
Figdir="/Users/jim/_mymods/AMAK/examples/bogo/figs"
ret_dir="/Users/jim/_mymods/AMAK/examples/bogo/retro"
setwd(codePath)
source(paste(fndir,"adfunctions.r",sep=""))
#source(paste(fndir,"adfunctions2.r",sep=""))
source("diagnostics_v2.r")
source("ADMB2R_15102013.r")
source("compareRuns.r")

# Read in the output of the assessment
run_name="mod1"
dat_name="bog.dat"
amak.in  <- read.dat(iFilename = paste(dat_name,sep=""),iPath=inputPath)
amak.out <- readList(file.path(inputPath,paste("arc/",run_name,"_R.rep",sep="")))
amak.ypr <- readYPR(file.path(inputPath,paste( "arc/",run_name,".yld",  sep="")))

plot(density(rlnorm(5000,meanlog=0.2,sdlog=4.)))
(mean(rlnorm(5000,log(0.2),4.)))
log(rlnorm(100))
mod1.1 <- readList(file.path(inputPath,paste("For_R.rep",sep="")))
mod1.0 <- readList(file.path(inputPath,paste("arc/mod1.0_R.rep",sep="")))
mod1.1 <- readList(file.path(inputPath,paste("arc/mod1.1_R.rep",sep="")))
mod1.2 <- readList(file.path(inputPath,paste("arc/mod1.2_R.rep",sep="")))

AgeFitsSrv(mod1.0,rec_age=4,case_label="2014 1.0 assessment")
AgeFitsSrv(mod1.1,rec_age=4,case_label="2014 1.1 assessment")
AgeFitsSrv(mod1.2,rec_age=4,case_label="2014 1.2 assessment")

mod1 <- readList(file.path(inputPath,paste("arc/mod1_R.rep",sep="")))
mod2 <- readList(file.path(inputPath,paste("arc/mod2_R.rep",sep="")))
mod3 <- readList(file.path(inputPath,paste("arc/mod3_R.rep",sep="")))
mod4 <- readList(file.path(inputPath,paste("arc/mod4_R.rep",sep="")))
# Model selected for 2013
mod2013 <- readList("../arc/mod2013_R.rep")

#diagnostics(mod1,amak.in,amak.ypr,what=c("input","fit","projections"))
#diagnostics(amak.out,amak.in,what=c("input","fit","projections"))
#diagnostics(amak.out,amak.in,amak.ypr,what=c("fit","projections"))
lstOuts   <- list( Model_1= mod1.0, Model_1.1= mod1.1, Model_1.2= mod1.2)
lstOuts   <- list( Model_1.0= mod1.0, Model_1.1= mod1.1 )
lstOuts   <- list( Model_1= mod1, Model_2= mod2, Model_3= mod3)
thislast  <- list( "Model 1 this year"= mod1, "Last year's model"= mod2013)

# used in doc to compare this year w/ last...
compareTime(lstOuts,"SSB",SD=T,Sum=NULL,startYear=1977,ylim=c(0,2000000),main="Spawning biomass",legendPos="topright")

compareTime(lstOuts,"SSB_NoFishR",SD=T,Sum=NULL,startYear=1977,ylim=c(0,1.0))
compareTime(lstOuts,"SSB",SD=T,Sum=NULL,legendPos="topright",startYear=1977,ylim=c(0,500000))
compareTime(lstOuts,"SSB",SD=T,Sum=NULL,legendPos="topleft",startYear=1970)
compareTime(lstOuts,"SSB",SD=F,Sum=NULL,legendPos="topleft",startYear=1970)
compareTime(lstOuts,"SSB",SD=F,Sum=NULL,legendPos="topleft",startYear=1953)
compareTime(lstOuts,"SSB",SD=T,Sum=NULL,legendPos="topleft",startYear=1970,ylim=c(0,6e5))
compareTime(lstOuts,"R",SD=T,legendPos="topright",startYear=1990)
compareTime(lstOuts,"R",legendPos="left",SD=F)
compareTime(lstOuts,"TotBiom",legendPos="topright",SD=T)
compareMatrix(lstOuts,"TotF",SD=F,legendPos="left",Sum=NULL,YrInd=jjm1.2$Yr,Apply=mean,ylim=c(0,0.8))
compareMatrix(lstOuts,"N",   SD=F,legendPos="left",         YrInd=mod1$Yr,Apply=sum)

#pdf(paste(Figdir,"SurvFit.pdf",sep=""),width=9, height=7)
rec_age=4
p.rec.hist(mod1.0,main="Model 1.0",ylab="Recruitment",fy=1983,ly=2014,plotmean="T")
p.rec.hist(mod1.1,main="Model 1.1",ylab="Recruitment",fy=1983,ly=2014,plotmean="T")
,ylim=c(0,1.5e6))
p.rec.hist(mod1.1,main="Model 1",ylab="Recruitment",fy=1977,ly=2014,plotmean="T")
Mest = read.table("../Mmcmc.rep")
Mest=as.vector(Mest[,1])
plot(density(Mest),xlab="Natural mortality rate",main="Model 1.1")
abline(h=0,wid=.2)
?density
density(Mest)
is.vector(Mest)
# Survey fit
source("IndexFit.r")
IndexFit(mod1.0,yf=1985,yl=2014,f=1,main="Model 1.0", ,ylab="Survey biomass (t)",ylim=c(0,2.75e6))
IndexFit(mod1.1,yf=1985,yl=2014,f=1,main="Model 1.1", ,ylab="Survey biomass (t)",ylim=c(0,2.75e6))
names(mod1.1)
lines(mod1.1$Obs_Survey_1[,c(1,3)],lty=2)
lines()
IndexFit(mod1.1,yf=1985,yl=2014,f=1,main="Model 1.1", ,ylab="Survey biomass (t)")
p.sur.stk(mod1,f=1)
p.catch.fit(mod1.1,f=1,ylim=c(0,400000))
plot(mod1$SSB,typ="b",ylab="SSB",xlab="Year",ylim=c(0,.85e6))

#pdf(paste(Figdir,"TotB.pdf",sep=""),width=9, height=7)
p.biom.pol(mod1,typ="SSB",main="Model 1",new=F,fy=1977,ly=2014)
lines(mod1$TotBiom[,1],mod1$TotBiom[,2],col="black",lty=2,lwd=3)
p.biom.pol(mod1,typ="TB",main="Model 1",new=F,fy=1977,ly=2014)
#dev.off()

styr=1977
p.stock.rec(mod1,main="Atka mackerel, model 1")
p.eff.n(mod1,typ="F",f=1,main="Model 1")
p.eff.n(mod1,typ="S",f=1,main="Model 1")
AgeFits(mod1,rec_age=1,case_label="2014 1 assessment")
AgeFitsSrv(mod1.1,rec_age=4,case_label="2014 1 assessment")
#dev.off()
#detach(dat)
# spawning biomass and last year's estimates
p.biom.pol(mod1,typ="TB",new=F)
lines(1977:2013,mod1$F_fsh_1[,3],lwd=2)
#names(mod1)

# Rec
p.biom.stk(mod1,typ="R")
# Numbers at age
p.bub.age(mod1,siz=200)
#dev.off()

p.rec.hist(mod2,fy=1977,ly=2014,main="Model 2")
lines(modsigmaR$R[,1],modsigmaR$R[,2],col="purple",lwd=2)
#dev.off()

# Likelihood table
tab       <- cbind(lstOuts[[1]]$Like_Comp_names,do.call(cbind,lapply(lstOuts,function(x){round(x[["Like_Comp"]],2)})))
tab
do.call(cbind,lapply(lstOuts,function(x){round(x[["Like_Comp"]],2)}))
do.call(cbind,lapply(lstOuts,function(x){round(x[["Like_Comp"]],2)}))
rbind(
cbind("q",do.call(cbind,lapply(lstOuts,function(x){round(x[["q_1"]][1,2],2)}))),
cbind("Npars",do.call(cbind,lapply(lstOuts,function(x){round(x[["Num_parameters_Est"]],2)}))),
cbind("M",do.call(cbind,lapply(lstOuts,function(x){round(x[["Mest"]][2],2)}))),
cbind("SigmaR",do.call(cbind,lapply(lstOuts,function(x){round(x[["Sigmar"]][2],2)}))),
cbind("EffN_Fish",do.call(cbind,lapply(lstOuts,function(x){round(mean(x[["EffN_Fsh_1"]][,2]),2)}))),
cbind("EffN_Surv",do.call(cbind,lapply(lstOuts,function(x){round(mean(x[["EffN_Survey_1"]][,2]),2)}))),
tab,
cbind("F2014",do.call(cbind,lapply(lstOuts,function(x){round((x[["F_fsh_1"]][38,2]),2)}))),
cbind("F2014/F40%",do.call(cbind,lapply(lstOuts,function(x){round((x[["F_fsh_1"]][38,2])/(x[["F40_est"]]),2)}))),
cbind("B 1977",do.call(cbind,lapply(lstOuts,function(x){round((x[["TotBiom"]][1,2]),0)}))),
cbind("CV",do.call(cbind,lapply(lstOuts,function(x){round((x[["TotBiom"]][1,3])/(x[["TotBiom"]][1,2])*100,0)}))),
cbind("B 2014",do.call(cbind,lapply(lstOuts,function(x){round((x[["TotBiom"]][38,2]),0)}))),
cbind("CV",do.call(cbind,lapply(lstOuts,function(x){round((x[["TotBiom"]][38,3])/(x[["TotBiom"]][38,2])*100,0)}))),
cbind("2001 YC",do.call(cbind,lapply(lstOuts,function(x){round((x[["R"]][26,2]),0)}))),
cbind("CV",do.call(cbind,lapply(lstOuts,function(x){round((x[["R"]][26,3])/(x[["R"]][26,2])*100,0)}))),
cbind("2006 YC",do.call(cbind,lapply(lstOuts,function(x){round((x[["R"]][31,2]),0)}))),
cbind("CV",do.call(cbind,lapply(lstOuts,function(x){round((x[["R"]][31,3])/(x[["R"]][31,2])*100,0)})))
)

?do.call
names(mod1)
write.csv(tab,file=file.path(inputPath,"LikelihoodTable2014.csv"),row.names=F)
system(paste("open ",inputPath,"/Likelihoodtable2014.csv",sep=""))

mod1$Like_Comp
mod1$Like_Comp_names
SSB_Lastyr=read.table("clipboard")
names(mod1)

p.biom.pol(mod0,typ="SSB",new=F)
p.biom.pol(mod1,typ="SSB",new=F)
p.biom.pol(mod2,typ="SSB",new=F,main="Model 2".ly=2013)
lines(mod0$SSB[,1],mod0$SSB[,2],col="red")
lines(mod1$SSB[,1],mod1$SSB[,2],col="green")

#++++SSB CV figure=========================
plot(d3$SSB[,1],d3$SSB[,3]/d3$SSB[,2],typ="l",lty=2,ylim=c(0,.4),ylab="CV on spawning biomass",xlab="Year",cex.lab=1.4)
lines(d3$SSB[,1],d1$SSB[,3]/d1$SSB[,2],lwd=2)
lines(d3$SSB[,1],d2$SSB[,3]/d2$SSB[,2],lty=1)
lines(d3$SSB[,1],d7$SSB[,3]/d7$SSB[,2],lty=3)
legend(1968,.4, c("sigma_d=0.1","sigma_d=0.2","sigma_d=0.3", "sigma_d=1.0"),lty=c(1,1,2,3),lwd=c(2,1,1,1))

lines(modvsel$SSB[,1],modvsel$SSB[,2],col="red")
lines(mod2$SSB[,1],mod1$SSB[,2],col="purple",lwd=2)
lines(mod2$SSB[,1],mod2$SSB[,2],col="green",lwd=2)
lines(mod2$SSB[,1],mod3$SSB[,2],col="pink",lwd=2)
lines(mod2$SSB[,1],mod4$SSB[,2],col="black",lwd=2)

lines(modestM$SSB[,1],modestM$SSB[,2],col="salmon",lwd=2)
lines(modsigmaR$SSB[,1],modsigmaR$SSB[,2],col="purple",lwd=2)
modestM$Index_Q_1
names(mod1)

#++++Selectivity figure=========================
SelLastYr=c(0.00228954, 0.0333104,	0.337153,	0.879725,	1.13117,	1.32736,	1.619,	1.61509,	1.46665,	1.29413,	1.29413)
SelLastYr[[1]][1:11]
d1=readList(paste(outdir,"arc\\ds.1_R.rep",sep=""))
d2=readList(paste(outdir,"arc\\ds.2_R.rep",sep=""))
d3=readList(paste(outdir,"arc\\ds.3_R.rep",sep=""))
d7=readList(paste(outdir,"arc\\ds1.0_R.rep",sep=""))
q1.3=readList(paste(outdir,"arc\\q1.3_R.rep",sep=""))
plot(d1$N[36,3:12],typ="p",pch=19)
lines(d7$N[36,3:12])
k=36
plot(1:11,d3$sel_fsh_1[k,3:13]/max(d3$sel_fsh_1[k,3:13]),typ="l", ylab="Selectivity",xlab="Age",lwd=3, cex.lab=1.8)
lines(d1$sel_fsh_1[k,3:13]/max(d1$sel_fsh_1[k,3:13]),lty=2)
lines(d7$sel_fsh_1[k,3:13]/max(d7$sel_fsh_1[k,3:13]),lty=3)
lines(q1.3$sel_fsh_1[k,3:13]/max(q1.3$sel_fsh_1[k,3:13]),lty=3)
lines(SelLastYr/max(SelLastYr),lty=4)
SelLastYr
abline(h=.5)
legend(1,.95, c("sigma_d=0.3","sigma_d=0.1","sigma_d=1.0", "2011 Assessment"),lty=1:4,lwd=c(3,1,1,1,1))
#END ofSelectivity figure=========================

IndexFit(mod2,yf=1989,yl=2012,f=1,main="Model 2",ylab="Survey biomass (t)")
IndexFit(mod1,yf=1989,yl=2012,f=1,main="Model 1",ylab="Survey biomass (t)")
lines(mod1$TotBiom[,1],mod1$TotBiom[,2],lty=2,lwd=2)
pdf("Atka_2013.pdf",width=9, height=7)
Mntns(mod0,"Model 0")
Mntns(mod1,"Model 1")
Mntns(mod2,"Model 2")
mod1$Q_Survey_1
mod2$Q_Survey_1
dev.off()

pdf(paste(Figdir,"Selectivity.pdf",sep=""),width=7, height=11)
par(mfrow=c(1,2))
sel.age.mountain(mod1, f=1, new="F",typ="F", xvec=c(1:11),main="Model 1")
sel.age.mountain(mod2, f=1, new="F",typ="F", xvec=c(1:11),main="Model 2")
sel.age.mountain(mod2.2, f=1, new="F",typ="F", xvec=c(1:11),main="Model 2.2")
sel.age.mountain(mod1.2, f=1, new="F",typ="F", xvec=c(1:11),main="Model 2.2")
dev.off()
par(mfcol=c(1,1),mar=c(5,5,4,2) + 0.1)

p.catch.fit(mod1,f=1,ylab="Catch biomass (t)",ylim=c(0,120000))
names(mod1)

mod1$Fshry_names="Trawl"
spwn_ratio(mod1,main="Model 1")
cont.f.age.res(mod1, typ = "F", f = 1, lage = 1, hage = 11, cl ="COL")
p.bub.age(mod1,lage=1,hage=11,fy=1977,ly=2011,siz=100)
detach(dat)
Plot_Phase()
Plot_Fspr()
AgeFits(mod2,f=1,case_label="2013 assessment",rec_age=1)
AgeFits(mod1,f=1,case_label="2013 assessment",rec_age=1)

modsigmaR$R
                 xlab="Age",ylab="Year",zscale=2.5,new=F,cex.yax=1.,fy=1980)
detach(dat)
IndexFit(mod,yf=1980,yl=2010,f=2,main=main)

par(mfcol=c(1,1))

# show fit to catch biomass
CatchFit(mod2.2)

# show spawning biomass relative to population with no fishing
spwn_ratio(mod1,fy=1977,ly=2013)
fix(spwn_ratio)

detach(dat)
# example of writing multiple plots to pdf file:
#pdf("figs/agefits.pdf",width=9, height=7)
  #AgeFits(am1,f=1)
#dev.off()

# another example of writing multiple plots to pdf file:
#pdf("figs/survey_fit.pdf",width=7, height=9)
#Mntns(am1,"Model 1")
    # Indices(am1,"Model 1")
par(mfrow=c(1,1))
IndexFit(mod1,main="Model 1",yf=1990,ylab="Survey biomass (t)")
detach(dat)
Plot_Fspr()

#spwn_ratio(am1)
#plt_proj(am1)
#dev.off()

#=====================
# Retro
# get all retrospectives
#=====================
setwd(outdir)
outdir
retouts <- list()
retouts <- list( R0=mod1, R1= retro1, R2= retro2,
  R3= retro3,
  R4= retro4 ,
  R5= retro5 ,
  R6= retro6 ,
  R7= retro7 ,
  R8= retro8 ,
  R9= retro9 ,
  R10= retro10
  )
tab = list(R0=mod1$SSB)

for (i in 1:10) { tab=cbind(tab,retouts[[i]]$SSB)}

for (i in 0:15) {
  rn=paste("retro/r_",i,".rep",sep="")
  mn=paste("retro",i,sep="")
  assign(mn,readList(rn))
  print(rn)
}
#pdf(paste(Figdir,"Retro_Mods.pdf",sep=""),width=9, height=6)
p.biom.pol(retro0,typ="SSB",main="Model 1",new=F,fy=1977,ly=2014)
for (i in 1:15) {
  rn=paste("retro",i,sep="");
  lines(get(rn)$SSB[,1],get(rn)$SSB[,2],col=i)
  lr=length(get(rn)$SSB[,1])
  points(get(rn)$SSB[lr,1],get(rn)$SSB[lr,2],pch=19,col=i)
}

plot(retro0$SSB[,1],rep(0,length(retro0$SSB[,1])), ylim=c(-.7,.7), ylab="Relative difference from terminal year",
type="l",xlab="Year",lty=2,lwd=2)
 for (i in 1:15) {
  rn=paste("retro",i,sep="");
  lr=length(get(rn)$SSB[,1])
  lines(get(rn)$SSB[,1],get(rn)$SSB[,2]/retro0$SSB[1:lr,2]-1,col=i)
  #points(get(rn)$SSB[lr,1],get(rn)$SSB[lr,2],pch=19,col=i)
}
# Mohn's rho
rc = retro0$SSB[,2]
ntmp=0
rho=0
for (i in 1:15) {
  dtmp=get(paste("retro",i,sep=""))$SSB
  lr=length(dtmp[,1])
  ntmp= ntmp+(dtmp[lr,2] -rc[lr])/rc[lr]
  #rho = rho + (-(ALL[i,2]-ALL[*tsyrs-i,2+i]))/ALL[(j)*tsyrs-i,2]
  rho = rho + (-(dtmp[i,2]-rc[i]))/rc[lr]
  print(paste(i,ntmp/i,rho))
}
       <- cbind(lstOuts[[1]]$Like_Comp_names,do.call(cbind,lapply(lstOuts,function(x){round(x[["Like_Comp"]],2)})))
  #points(get(rn)$SSB[lr,1],get(rn)$SSB[lr,2],pch=19,col=i)
  #print(dtmp)
  #print(paste(dtmp[,1],rc[lr]))
 for(i in 1:15) {

dev.off()

p.biom.pol(retro2,typ="SSB",main="Model 1",new=F,fy=1977,ly=2013)
for (i in 1:9) {
  rn=paste("retro1",i,sep="");
  lines(get(rn)$SSB[,1],get(rn)$SSB[,2],col=i)
}
pdf(paste(Figdir,"Retro_Mod2.pdf",sep=""),width=7, height=9)
par(mfrow=c(2,1))
p.biom.pol(retro0,typ="SSB",main="Model 2",new=F,fy=1977,ly=2012)
#plot(retro0$SSB[,1],retro0$SSB[,2],ylim=c(0,550),      ylab="Spawning biomass (kt)",type="l",lwd=2,xlab="",lty=2)
ssb=1966:2013
retro0$R
names(retro1)
rrr=1977:2012
for (i in 0:10) {
  rn=paste("retro",i,sep="");
  lines(get(rn)$SSB[,1],get(rn)$SSB[,2],col=i)
  ssb=rbind(ssb,c(t(get(rn)$SSB[,2]),rep(NA,i)))
  rrr=rbind(rrr,c(t(get(rn)$R[,2]),rep(NA,i)))
  }
write.csv(ssb,"Atka_SSB.csv")
write.csv(rrr,"Atka_rec.csv")

system("atka_ssb.csv")
?write.csv
rrr
rep(NA,2)
plot(retro0$SSB[,1],rep(0,length(retro0$SSB[,1])),
     ylim=c(-.7,.7),
     ylab="Relative difference from terminal year",
     type="l",xlab="Year",lty=2,lwd=2)
for (i in 1:10) {
  rn=paste("retro",i,sep="");
  lines(get(rn)$SSB[,1],
        (get(rn)$SSB[,2]/retro0$SSB[1:(48-i),2])-1,col=i)
  }

dev.off()
p.biom.pol(mod2,typ="SSB",n.mod=1,main="Model 2",new=F,fy=1977,ly=2013)

p.biom.pol(mod2,typ="SSB",n.mod=2,mod1,main="Model 1",new=F,fy=1977,ly=2013)
lines(SSB_Lastyr[,1],SSB_Lastyr[,2]/2,lwd=2,col="red")

# Plot selectivity in multiple crappy panels
p.select.hist(mod1,typ="F",h="T",f=1,lage=1,hage=11,fy=1985,ly=2000)
# Plot selectivity in multiple crappy color grayscale
c.select(mod1)
dev.off()


# Copyright Syncfusion Inc. 2001 - 2016. All rights reserved.
# Use of this code is subject to the terms of our license.
# A copy of the current license can be obtained at any time by e-mailing
# licensing@syncfusion.com. Any infringement will be prosecuted under
# applicable laws.

# If you are not familiar with R you can obtain a quick introduction by downloading
# R Succinctly for free from Syncfusion - http://www.syncfusion.com/resources/techportal/ebooks/rsuccinctly
# R Succinctly is also included with this installation and is available here
# Installed Drive :\Program Files (x86)\Syncfusion\Essential Studio\XX.X.X.XX\Infrastructure\EBooks\R_Succintly.pdf OF R Succinctly
# Uncomment below lines to install necessary packages if not installed already
#install.packages("gbm")
#install.packages("devtools")
#install.packages("rJava")
#install.packages("randomForest")
#install.packages("githubinstall")
#Use 'r2pmml' package version v0.3.0 or below since, the function 'poisson' has been deprecated in later versions.
#library(githubinstall)
#gh_install_packages("jpmml/r2pmml", ref="0.3.0")

# Load below packages
library(devtools)
library(gbm)
library(rJava)
library(r2pmml)
library(randomForest) # This package is specifically loaded for imports85 dataset shipped within it.

# Here we directly load the audit dataset installed with the "randomForest" package.
data(imports85)

# rename column names in imports85 dataset from randomForest package
importsOriginal <- setNames(imports85, c("Symboling","Normalized_Losses","Make","Fuel_Type","Aspiration","Num_Of_Doors","Body_Style","Drive_Wheels","Engine_Location",
"Wheel_Base","Length","Width","Height","Curb_Weight","Engine_Type","Num_Of_Cylinders","Engine_Size","Fuel_System","Bore","Stroke","Compression_Ratio",
"Horse_Power","Peak_Rpm","City_Mpg","Highway_Mpg","Price"))

# Omit rows with missing values
importsOriginal = na.omit(importsOriginal)

# Code below demonstrates loading the same dataset from a CSV file shipped with our installer.
# Please check installed samples (Data) location to set actual working directory
# Uncomment below lines and comment out the code to read data from CSV file.
# setwd("C:/actual_data_location")
# imports= read.csv("Imports.csv")

# Divide dataset for training and test
trainData<-importsOriginal[1:128,]
testData<-importsOriginal[129:159,]

# Applying GBM - poisson function to predict censlink functions
imports_GBM =  gbm(Price~ Symboling+Normalized_Losses+Fuel_Type+Aspiration+
        Num_Of_Doors+Body_Style+Drive_Wheels+Wheel_Base+Length+Width+Height+
        Curb_Weight+Engine_Size+Bore+Stroke+Compression_Ratio+Horse_Power+
        Peak_Rpm+City_Mpg+Highway_Mpg,data=trainData, distribution="poisson")

# Display the predicted results
# Predict "price" column probability for test data set
importsTestProbabilities = predict.gbm(imports_GBM, newdata=testData, n.trees=100,type="link")
# Display predicted probabilities
importsTestProbabilities

# PMML generated will be of version v4.2 since, older version(v0.3.0) 'r2pmml' has been loaded.
r2pmml(imports_GBM ,"Imports.pmml")

# The code below is used for evaluation purpose.
# The model is applied for original imports data set and predicted results are saved in "ROutput.csv"
# "ROutput.csv" file used for comparing the R results with PMML Evaluation engine results

# Applying GBM to entire dataset and save the results in a CSV file
importsEntireProbabilities = predict.gbm(imports_GBM, importsOriginal, n.trees=100,type="link")

# Save predicted value in a data frame
result = data.frame(importsEntireProbabilities)
names(result) = c("Predicted_price")

# Write the results in a CSV file
write.csv(result,"ROutput.csv",quote=F)


library(Seurat)

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

fn = "data/H1_day0_scranNorm_adtbatchNorm_dist_clustered_TSNE_labels.rds"
h1 = readRDS(fn)

df.subj = h1@meta.data %>% dplyr::mutate(response = str_remove(adjmfc.time, "d0 ")) %>%
  dplyr::select(subject=sampleid, response) %>%
  dplyr::mutate(subject = factor(subject)) %>%
  distinct() %>%
  dplyr::arrange(subject)

dn.out = "results/sig_scores"
dir.create(dn.out, showWarnings = F, recursive = T)

sig.list = readRDS("sig/sig.list.RDS")

for(clustering in 0:3) {
  cat("\n", clustering)
  h1 = SetAllIdent(h1, id = glue::glue("K{clustering}"))

  clust.names = levels(h1@ident)

  for(s in names(sig.list)) {
    cat("\n", s, " ")
    sig = sig.list[[ s ]]

    score.mat = matrix(nrow = nrow(df.subj), ncol = length(clust.names))
    colnames(score.mat) = clust.names
    rownames(score.mat) = df.subj$subject

    for(cl in clust.names) {
      cat(cl, " ")

      tobj = SubsetData(h1, ident.use = cl)

      dat = tobj@data
      meta = tobj@meta.data %>%
        dplyr::rename(subject = sampleid) %>%
        dplyr::mutate(subject = factor(subject, levels=df.subj$subject))

      gi = rownames(dat) %in% sig

      dat2 = aggregate(t(as.matrix(dat[gi,,drop=F])), list(subject = meta$subject), mean, drop=F)
      dat2[is.na(dat2)] = 0
      mat = dat2 %>%
        tibble::column_to_rownames("subject") %>%
        data.matrix()

      score.mat[,cl] = get_score(t(mat))
    } # cl
    # colnames(score.mat) = clust.labels
    score.mat %>% as.data.frame() %>% tibble::rownames_to_column("subject") %>%
    fwrite(glue::glue("{dn.out}/scores_{s}_{clustering}.txt"), sep = "\t")
  } # sig
} # clustering


source("code/plots.r")
load("data/ref.set.edgeR.RData")
load("data/ref.set.edgeR.et.RData")
load("data/x.all.Rdata")
load("data/test.set.edgeR.Rdata")
load("data/test.set.edgeR.et.Rdata")

tp.edgeR <- ref.set.edgeR
#mp.edgeR <- setdiff(Reduce(union, ref.set.edgeR), Reduce(intersect, ref.set.edgeR))
tn.edgeR <- setdiff(rownames(x.all), c(tp.edgeR, mp.edgeR))

tp.edgeR.et <- ref.set.edgeR
mp.edgeR.et <- mp.edgeR
tn.edgeR.et <- setdiff(rownames(x.all), c(tp.edgeR.et, mp.edgeR.et))

par(mfrow=c(2,2))
analyze_data(tp.edgeR,mp.edgeR,tn.edgeR,test.set.edgeR,main="ep1", 5000, 40)
sens_spec(tp.edgeR,mp.edgeR,tn.edgeR,test.set.edgeR,main="ep1", 40)

analyze_data(tp.edgeR.et,mp.edgeR.et,tn.edgeR.et,test.set.edgeR.et,main="ep1", 5000, 40)
sens_spec(tp.edgeR.et,mp.edgeR.et,tn.edgeR.et,test.set.edgeR.et,main="ep1", 40)


#!/usr/bin/env Rscript
source("common.r")

checkPaddleParams <- function(parameters) {
    checkPaddle <- 0
    if (!(parameters$parameters$pThresholdDirection == "above" | parameters$parameters$pThresholdDirection == "below")) {
        write("Error: pThreshold direction should either be above or below",stderr())
    } else if (parameters$parameters$pThreshold < 1 ) {
        write("Error: pThreshold should be greater than 1",stderr())
    } else if (parameters$parameters$minLength < 0) {
        write("Error: minLength should be greater than 0",stderr())
    } else {
        checkPaddle <- 1
    }
    return(checkPaddle)
}

findPaddle <- function(panel,parameters) {

    panel$`rotationrate:x`<- as.numeric(as.character(panel$`rotationrate:x`))

    write("Calculating dominant frequency",stderr())
    pEntropy <- findSpecEntropy(panel$`rotationrate:x`,
                                parameters$windowSize,
                                parameters$overlapStep,
                                1)

    write("Interpolating frequency",stderr())
    paddleFreq <- getFreq(      panel$`rotationrate:x`,
                                pEntropy$domFreq,
                                pEntropy$nFrames,
                                parameters$windowSize,
                                parameters$minLength)

    write("Calculating the time stamps of the paddle labels",stderr())
    freqLabels <- outputLabels( paddleFreq,
                                parameters$windowSize,
                                panel$time,
                                parameters$pMergeThreshold)

    write("Converting results to JSON", stderr())

    results <- list()
    if ( freqLabels$startTime == 0 && freqLabels$endTime == 0 ) {
        results <- vector()
    } else {
        for (i in 1:length(freqLabels$startTime)) {
            labelList<-list(
                startTime=unbox(freqLabels$startTime[i]),
                endTime=unbox(freqLabels$endTime[i]),
                type=unbox(parameters$eventType))
            results <- append(results, list(labelList)) # Convert to list objects
        }
    }
    return (results)
}

# Interpolate the frequency based on the stretches
getFreq <- function(pData,domFreq,nFrames,winSize,minLength) {

    domFreq[domFreq!=1.171875]<-0
    domFreq[domFreq==1.171875]<-1 #2.34375

    transList <- findTransition(domFreq)
    fStartTimes <- transList$wStartTimes
    fEndTimes <- transList$wEndTimes

    for (i in 1:length(fStartTimes)) {
        if ((fEndTimes[i]-fStartTimes[i])<minLength){
            domFreq[fStartTimes[i]:fEndTimes[i]]<-0
        }
    }

    freq<-rep(0,length(pData))
    #freq[((winSize/2)*(1:length(Entropy)))]<-domFreq
    freq[((winSize/2)*(1:nFrames))]<-domFreq

    idx <- which(freq!=0)
    for( i in 1:length(idx) ){
        freq[idx[i]:(idx[i]+(winSize-1))]<-freq[idx[i]]
    }

    return(freq)
}
#freqLabels$startTime<-freqLabels$startTime-panel$time[1]
#freqLabels$endTime<-freqLabels$endTime-panel$time[1]


####################################################################################
#
# Mark Cembrowski, Janelia Research Campus, Nov 11 2016
#
# This function renders a heatmap of genes for single cell data.
#
####################################################################################

singleCellHeatmap <- function(gsnList,label=T,rMax=-1){

	theClasses <- c('pyramidal CA1','oligodendrocytes',
			'interneurons','astrocytes_ependymal',
			'microglia','endothelial-mural')

	subMeta <- subset(scMeta,tissue=='ca1hippocampus')

	geneInMat <- gsnList[gsnList%in%rownames(scHip)]
	subMat <- scHip[geneInMat,]

	allStats <- as.data.frame(matrix(nrow=0,ncol=length(geneInMat)))

	for (curClass in theClasses){
		toKeep <- subMeta$level1class==curClass

		curMat <- subMat[,toKeep]
		curStats <- apply(curMat,1,mean)

		allStats <- rbind(allStats,curStats)
		colnames(allStats) <- names(curStats)
		rownames(allStats)[nrow(allStats)] <- curClass
	}

	# Sort data for plotting.
	theOrder <- apply(allStats,2,max)
	allStats <- allStats[,order(theOrder)]

	# Order
	thres1 <- sum(apply(allStats,2,max)<1)
	thres01 <- sum(apply(allStats,2,max)<0.1)
	print(paste('From',ncol(allStats),'genes:'))
	print(paste(thres1,'less than 1 mol/avg'))
	print(paste(thres01,'less than 0.1mol/avg'))

	# Melt data frame for plotting.
	allStatsMelt <- as.data.frame(melt(as.matrix(allStats)))
	colnames(allStatsMelt) <- c('grp','gene','count')

	if(rMax>0){
		# Reset for plotting purposes in ggplot.
		allStatsMelt$count[allStatsMelt$count>rMax] <- rMax
	}

	# Plot.
	heatGr <- ggplot(allStatsMelt,aes(x=grp,y=gene))
	heatGr <- heatGr + geom_tile(aes(fill=count),colour='white')
	if(rMax>0){
		theRangeMax <- rMax + 0.0001
	}else{
		theRangeMax <- max(allStatsMelt$count)+0.0001
	}

	# Define other stylistic features.
	heatGr <- heatGr + scale_fill_gradientn(colours=c('cyan','white','red'),
		values=c(0,0.5,1),guide='colorbar',limits=c(0,theRangeMax)) # Changed from green and purple.
	heatGr <- heatGr + theme(panel.background=element_blank())
	heatGr <- heatGr + theme(axis.text.x = element_text(angle=45,hjust=1))
	heatGr <- heatGr + labs(x='Cell type',y='Gene')
	heatGr <- heatGr + scale_x_discrete(limits=c('pyramidal CA1','interneurons',
			'oligodendrocytes','astrocytes_ependymal','endothelial-mural',
			'microglia'))
	print(heatGr)

	invisible(heatGr)
}


files = list.files('./',recursive=1,pattern='Query-Results-Correctly-Processed-Time.csv$')

s <- function(data, x) {
	return (sum(data[x] > 0))
}

for (file in files)
{
	graphic = paste(file, 'plot.pdf',sep='.')
	pdf(graphic)

	data = read.csv(file, header=T)
	completed = subset(data, leancor > 0)
	completed = completed[order(completed$leancor),]

	par(mfrow=c(2,2))

	ylim = range(range(data[4]), range(data[3]), range(data[2]))

	plot(sort(completed[,c(2)]),
		ylim=ylim,
		ylab='Processed time (ms)',
		xlab='Problem',
		main=names(data)[c(2)])

	plot(sort(completed[,c(3)]),
		ylim=ylim,
		ylab='Processed time (ms)',
		xlab='Problem',
		main=names(data)[c(3)])

	plot(sort(completed[,c(4)]),
		ylim=ylim,
		ylab='Processed time (ms)',
		xlab='Problem',
		main=names(data)[c(4)])

	counts = c(s(data, 2), s(data, 3), s(data, 4))
	ylim2 = range(c(0, 1.1 * max(counts)))

	bp = barplot(counts,
		ylim=ylim2,
		main="Correctly solved problems",
  		names.arg=names(data)[c(2,3,4)])

	text(x = bp, y = counts, label = counts, pos = 3, cex = 0.8)

	dev.off()
}