#-------------------------------------------------------------------------------
# ASKAT Package
#
# By: Karim Oualkacha
# Modifications by: Pablo Cingolani
# Optimization to the O(N^3) to O(N^2) complexity: Stepan Grinek
#
# 2013-01:
# --------
#
#	- FaST-LMM code moved to kinship.r
#
# Code review:
# ------------
#
#	- Joined all functions into one file (askar.r)
#
#	- Call to fastLmm should be in one function. It is now split in two or
#     more, thus creating several "global" names and variables (not modular).
#
#	- In VC.FaST.LMM you write to fastlmmOutFileName and immediately read
#     the same file. Why!?!? (you already have the data, why do you need
#     to write/read the same file?).
#
#		# Write results to 'fastlmmOutFileName'
#		output = scan(paste(genoOutFileName, sep=""), what="character", sep="\n")
#		write.table(output[2], file = fastlmmOutFileName, quote = FALSE, sep = " ", eol = "\r\n", na = "NA", row.names = FALSE, col.names = FALSE)
#		# Read results from fastlmmOutFileName. Why do you write and then read the same file?
#		VC.FaST.LMM = read.table(fastlmmOutFileName, header=FALSE)
#
#		Changed that code by this one liner:
#
#		VC.FaST.LMM = read.table(genoOutFileName, header=TRUE)
#
#	- In VC.FaST.LMM: Side effect deletes a file created outside the
#     function. This is bad practice, we should change it.
#
#	- Mixed assignment operators: '=' and '<-' are both used. R programmers
#     are quite 'orthodox' and usually prefer '<-'.
#
#	- Changed 'system("rm ...") by 'unlink(...)' which is system independent.
#
#	- Changed 'paste("...", sep="")' by just "...". It has the same effect, so
#     why the 'paste' function anyway?
#
#	- In VC.FaST.LMM, 'ans' is created just to return a list (removed).
#
#	- When writing pheno.txt and TFAM files, the separator was "    "
#     (i.e.four spaces). Changed it to single space. Apparently it only made
#     files larger and marginally slower to parse (when running this
#     millons of times, everything counts).
#
#	- Added return statement to clarify the code.
#
#	- Show ASKAT results in one line (using ASKAT_RESULTS) to make it easier
#	  for other programs to parse this output.
#
#
#																		2012
#-------------------------------------------------------------------------------

library(GenABEL)
library(nFactors)
library(CompQuadForm)

#-------------------------------------------------------------------------------
# ASKAT Main function
#
# ped    : Is the pedigree data file. It has subject IDs as first column (IDs
#          should be differents for all subjects), phenotype as second column
#          and region-based SNPs that will be analized together
#
# fastlmm: Results form fastlmm program (see kinship.r)
#
#-------------------------------------------------------------------------------
ASKAT <- function(ped, fastlmm, pACC=1e-9) {

	#####  STEP 1: Check for Missing Data and construction of pedigree without Missing Data   #####

	Y.trait = ped[,2]
	X = as.matrix(ped[,3:dim(ped)[2]])

	##### STEP 2: Under the NULL we call FaST-LMM to estimate the VCs ####
	estim.sigma.RG = as.numeric(as.character(fastlmm$nullGeneticVar));
	estim.sigma.e = as.numeric(as.character(fastlmm$nullResidualVar));

	S = fastlmm$S
	U = fastlmm$U

	##### STEP 3: Calculation of weights matrix W and the matrix K =GWG #####
	freq.MAF = apply(X, 2, mean)/2

  if( length(freq.MAF) == 1){
  	w <- dbeta(freq.MAF, 1, 25)
  	K.sqrt <- w * t(X)
  } else {
  	w <- vector(length = length(freq.MAF))
  	for (i in 1:length(freq.MAF)){
  	  w[i] <- dbeta(freq.MAF[i], 1, 25)
   	}
   	w <- diag(w)
  	K.sqrt <- w %*% t(X)
  }

##### STEP 2: ASKAT score test statistic calculations #####

	Gamma = estim.sigma.RG[1] / estim.sigma.e[1]
	UT<-t(U)
	D.0 <- (Gamma * S) + diag(1, dim(X)[1], dim(X)[1])
	inv.sqrt.D.0 <- diag(1/sqrt(diag(D.0)))
	inv.D.0 = diag(1/diag(D.0))
	un.n <- c(rep(1,dim(U)[1]))
	Z <- 1/(( t(un.n) %*% (U %*% (inv.D.0 %*% (UT %*% un.n))))[1,1])
	X.tilde <- inv.sqrt.D.0 %*% (UT %*% un.n)
	Y.tilde <- inv.sqrt.D.0 %*% (UT %*% Y.trait)
	s2 = estim.sigma.e
	P.0.tilde = (diag(1, dim(U)[1], dim(U)[2])) - (X.tilde %*% Z) %*% ((t(X.tilde)))
	RM <- ((K.sqrt %*% U) %*% inv.sqrt.D.0) %*%  P.0.tilde
	W <- RM %*% t(RM)

	Q <- (t(Y.tilde) %*% t(RM) %*% ((RM %*% Y.tilde)))/(2 * s2)
	out <- Get_PValue.Modif(W/2, Q, pACC)
  pvalue.davies <- out$p.value
  lambda <- out$lambda
  is_converge <- out$is_converge
	return( list(pvalue.ASKAT = pvalue.davies, Q.ASKAT = Q, Polygenic.VC = estim.sigma.RG, Env.VC = estim.sigma.e, lambda = lambda, is_converge = is_converge) );
}

#-------------------------------------------------------------------------------
# Get lambda UPD: heuristics: "IDX2 <- which(lambda1 > mean(lambda1[IDX1])/1e+05)"
# is removed to address accuracy issues
#-------------------------------------------------------------------------------
Get_Lambda <- function (K) {
	out.s <- eigen(K, symmetric = TRUE, only.values = TRUE)
	lambda1 <- out.s$values
	print(lambda1)
  IDX1 <- which(lambda1 >= 0)
	#IDX2 <- which(lambda1 > mean(lambda1[IDX1])/1e+05)
	if (length(IDX1) == 0) { fatalError("No Eigenvalue is bigger than 0!!") }
	lambda <- lambda1[IDX1]
	print(lambda)
  return( lambda );
  }

#-------------------------------------------------------------------------------
# Get p-value
# Note: This function was taken from SKAT package, modified as needed
#-------------------------------------------------------------------------------
Get_PValue.Modif <- function(K, Q, pACC){
	lambda <- Get_Lambda(K)
	p.val<-0
	p.val.liu<-0
	is_converge <- 0

  out <- davies(Q, lambda, acc = pACC)
  p.val <- out$Qq
  p.val.liu <- liu(Q, lambda)
  is_converge <- 1

  if (length(lambda) == 1) {
    p.val <- p.val.liu
    } else if (out$ifault != 0) {
      is_converge <- 0
    }

  if (p.val > 1 || p.val < 0) {
    is_converge <- 0
  }
  #cat("is converge:"); cat(is_converge)
  return(list(p.value = p.val, p.val.liu = p.val.liu, is_converge = is_converge, lambda = lambda))
}

#-------------------------------------------------------------------------------
# Fatal error
#-------------------------------------------------------------------------------
fatalError <- function(errStr)	{
	errStr <- paste('FATAL ERROR:',  errStr, "\n");
	stop( errStr );
}

#-------------------------------------------------------------------------------
# Main program
#-------------------------------------------------------------------------------

# Example of command line arguments
# You can just uncomment one of these lines for debugging.
#
# cmdLineArgs <- c( 'geno_cov.block.1_1.1.askat', 'geno_cov.tfam', 'geno_cov.block.1_1.kinship.RData', 20, './tmp_zzz', './fastlmmc', 'TRUE' )
# cmdLineArgs <- c( 'karim4k.block.1_100.1.askat', 'karim4k.tfam', 'karim4k.block.1_100.kinship.RData', 10, 'karim4k.block.1_100.1', 'fastlmmc', 'TRUE' )
#

#---
# Default values
#---
path.FastLmm   <- 'fastlmmc'
debug          <- FALSE
exitAfterError <- !debug		# Exit after any error, (unless we are in debug mode)
tmpDir         <- '.'

#---
# Parse  command line arguments
#---
if( !exists('cmdLineArgs') )    { cmdLineArgs <- commandArgs(trailingOnly = TRUE); }

# Stop if there are no command line argument
if( length(cmdLineArgs) < 1 ) { fatalError('No command line arguments!\n'); }

dataFileStr     <- cmdLineArgs[1];
tfamFile        <- cmdLineArgs[2];
kinshipFile     <- cmdLineArgs[3];
subBlockSize    <- as.integer( cmdLineArgs[4] );
pACC            <- as.double (cmdLineArgs[5]) #UPD new command line argument for the p-value accuracy
onlyOnce        <- (cmdLineArgs[6] == 'TRUE') || (cmdLineArgs[6] == 'T')
debug           <- debug || onlyOnce;		# Set debug mode

cat("ASKAT arguments:\n");
cat("\tData file/s         : ", dataFileStr , "\n" );
cat("\tTFAM file           : ", tfamFile , "\n" );
cat("\tKinship matrix file : ", kinshipFile , "\n" );
cat("\tSub-block size      : ", subBlockSize , "\n" );
cat("\tp-value accuracy    : ", pACC  , "\n" );
cat("\tTemporal dir        : ", tmpDir , "\n" );

#---
# Should we exit immediatly after any error or warning?
#---
if( exitAfterError ) {
	options(
		#warn=2,	# This will change all warnings into errors, so warnings will also be handled like errors
        error= quote({ traceback(); q("no",status=1,FALSE) })	# Make sure we get an error code after a 'stop'
	);
}

#---
# Read files
#---
if( debug )	{ cat('Loading tfam file: ', tfamFile , '\n' ); }
tfam <- read.csv(tfamFile, sep="", header=FALSE, col.names=c('familyId','individualId', 'paternalId', 'maternalId', 'sex', 'phenotype') );

if( debug )	{ cat('Loading kinship & FaST-LMM file: ', kinshipFile , '\n' ); }
load(kinshipFile);

# More than one file (comma separated list of files)
dataFiles <- unlist( strsplit(dataFileStr , ",") )

for( dataFile in dataFiles ) {
	cat("Data file : ", dataFile , "\n" );

	# Read data file
	if( debug )	{ cat('Load data file: ', dataFile, '\n' ); }
	dat  <- read.csv(dataFile, sep="", header=FALSE );

	#---
	# Iterate for each sub-block
	#---
	snpIdx <- 5:dim(dat)[2];							# Columns having SNP data
	ped12 <- tfam[,c(2,6)]; 							# First two columns of data structure (inividualID and phenotype)
	sbIdx <- seq( 1, dim(dat)[1] , by = subBlockSize );	# SubBlock indices

	# Iterate on every sub-block
	for( i in sbIdx )  {
		# Create pedigree matrix for ASKAT function
		maxBlock <- min( dim(dat)[1] , i+subBlockSize-1 );
		snpsBlock <- i:maxBlock;
		ped <- cbind( ped12, t(dat[snpsBlock,snpIdx]) );

		if( debug )	{ cat('Iterating on sub-block: ', paste( dat[i,1], ':', dat[i,4], ' - ' , dat[maxBlock,1], ':', dat[maxBlock,4], sep="") , '\n' ); }

		# Call ASKAT
		results <- ASKAT(ped, fastlmm, pACC)

		if (results$is_converge == 0) {Warning<-"\nWARNING: p-value calculation did not converge for this block, try to set pACC to a different value, default is 1e-9"}
    else{Warning<-""}

    # Show results
		cat("\nASKAT_RESULTS:"
			, "p-value:" , results$pvalue.ASKAT
			, "chr:pos:", paste( dat[i,1], ':', dat[i,4], ' - ' , dat[maxBlock,1], ':', dat[maxBlock,4], sep="")
			, "Block:", dataFile
			, "Sub-Block:", paste( i, ' - ', maxBlock, sep="" )
			, "Id:", paste( dat[i,2], ' - ', dat[maxBlock,2], sep="" )
			, "Q:", results$Q.ASKAT
			, "Polygenic.VC:", results$Polygenic.VC
			, "Env.VC:", results$Env.VC
			, "lambda:", results$lambda
      , "is converge:", results$is_converge
      , "\n"
			, sep="\t"
			);
    cat(Warning)

		if( onlyOnce )	{
			# Excecute only one sub-block? => Stop now
			fatalError('Execute onlyOnce is set. Stopping after first iteration.\n');
		}
	}
}


#' Comparators
#'
#' Binary comparators for \code{memuse} objects.
#'
#' Comparisons to numeric values are done at the byte level.
#'
#' @param e1,e2
#' \code{memuse}, \code{numeric}, or \code{object_size} objects.
#'
#' @return Returns a \code{memuse} class object.
#'
#' @examples
#' \dontrun{
#' x <- mu(2000)
#' y <- mu(3000)
#'
#' x < y
#' x <= y
#' x > y
#' x >= y
#' x == y
#' x != y
#' }
#'
#' @seealso \code{ \link{Constructor}, \link{memuse-class} }
#' @keywords Methods
#' @name Comparators
#' @rdname comparators
NULL

# --------------------------------------------------------
# mu-mu
# --------------------------------------------------------

#' @rdname comparators
#' @export
setMethod("==", signature(e1="memuse", e2="memuse"),
  function(e1, e2)
  {
    # if unit prefices disagree, use "IEC"
    if (e1@unit.prefix != e2@unit.prefix)
    {
      if (e1@unit.prefix != "IEC")
        e1 <- swap.prefix(e1)
      if (e2@unit.prefix != "IEC")
        e2 <- swap.prefix(e2)
    }

    # if names disagree, use "short"
    if (e1@unit.names != e2@unit.names)
    {
      if (e1@unit.names != "short")
        e1 <- swap.names(e1)
    }

    e1 <- convert_to_bytes(e1)
    e2 <- convert_to_bytes(e2)

    ret <- e1@size == e2@size

    return( ret )
  }
)

#' @rdname comparators
#' @export
setMethod("<", signature(e1="memuse", e2="memuse"),
  function(e1, e2)
  {
    # if unit prefices disagree, use "IEC"
    if (e1@unit.prefix != e2@unit.prefix)
    {
      if (e1@unit.prefix != "IEC")
        e1 <- swap.prefix(e1)
      if (e2@unit.prefix != "IEC")
        e2 <- swap.prefix(e2)
    }

    # if names disagree, use "short"
    if (e1@unit.names != e2@unit.names)
    {
      if (e1@unit.names != "short")
        e1 <- swap.names(e1)
    }

    e1 <- convert_to_bytes(e1)
    e2 <- convert_to_bytes(e2)

    ret <- e1@size < e2@size

    return( ret )
  }
)

#' @rdname comparators
#' @export
setMethod("<=", signature(e1="memuse", e2="memuse"),
  function(e1, e2)
  {
    e1 < e2 || e1 == e2
  }
)

#' @rdname comparators
#' @export
setMethod(">", signature(e1="memuse", e2="memuse"),
  function(e1, e2)
  {
    e2 < e1
  }
)

#' @rdname comparators
#' @export
setMethod(">=", signature(e1="memuse", e2="memuse"),
  function(e1, e2)
  {
    e2 < e1 || e1 == e2
  }
)

#' @rdname comparators
#' @export
setMethod("!=", signature(e1="memuse", e2="memuse"),
  function(e1, e2)
  {
    !(e1 == e2)
  }
)

# --------------------------------------------------------
# mu-numeric
# --------------------------------------------------------

#' @rdname comparators
#' @export
setMethod("==", signature(e1="memuse", e2="numeric"),
  function(e1, e2)
  {
    e1 <- convert_to_bytes(e1)

    ret <- e1@size == e2

    return( ret )
  }
)

#' @rdname comparators
#' @export
setMethod("<", signature(e1="memuse", e2="numeric"),
  function(e1, e2)
  {
    e1 <- convert_to_bytes(e1)

    ret <- e1@size < e2

    return( ret )
  }
)

#' @rdname comparators
#' @export
setMethod("<=", signature(e1="memuse", e2="numeric"),
  function(e1, e2)
  {
    e1 < e2 || e1 == e2
  }
)

#' @rdname comparators
#' @export
setMethod(">", signature(e1="memuse", e2="numeric"),
  function(e1, e2)
  {
    e2 < e1
  }
)

#' @rdname comparators
#' @export
setMethod(">=", signature(e1="memuse", e2="numeric"),
  function(e1, e2)
  {
    e2 < e1 || e1 == e2
  }
)

#' @rdname comparators
#' @export
setMethod("!=", signature(e1="memuse", e2="numeric"),
  function(e1, e2)
  {
    !(e1 == e2)
  }
)

# --------------------------------------------------------
# numeric-mu
# --------------------------------------------------------

#' @rdname comparators
#' @export
setMethod("==", signature(e1="numeric", e2="memuse"),
  function(e1, e2)
  {
    e2 <- convert_to_bytes(e2)

    ret <- e1 == e2@size

    return( ret )
  }
)

#' @rdname comparators
#' @export
setMethod("<", signature(e1="numeric", e2="memuse"),
  function(e1, e2)
  {
    e2 <- convert_to_bytes(e2)

    ret <- e1 < e2@size

    return( ret )
  }
)

#' @rdname comparators
#' @export
setMethod("<=", signature(e1="numeric", e2="memuse"),
  function(e1, e2)
  {
    e1 < e2 || e1 == e2
  }
)

#' @rdname comparators
#' @export
setMethod(">", signature(e1="numeric", e2="memuse"),
  function(e1, e2)
  {
    e2 < e1
  }
)

#' @rdname comparators
#' @export
setMethod(">=", signature(e1="numeric", e2="memuse"),
  function(e1, e2)
  {
    e2 < e1 || e1 == e2
  }
)

#' @rdname comparators
#' @export
setMethod("!=", signature(e1="numeric", e2="memuse"),
  function(e1, e2)
  {
    !(e1 == e2)
  }
)


# Util functions for getting soil information from LandGIS/SoilGrids
library(RCurl)
library(rjson)

# Given a data.frame that includes fields 'x' and 'y', return a URL at which we can find soil data from LandGIS
LGURL = function(points)
{
    return(paste0("https://landgisapi.opengeohub.org/query/point?lon=", points$x, "&lat=", points$y, "&coll=predicted250m&regex=sol_[^t].*_m_250m_b"))
}

# Same for SoilGrids
SGURL = function(points)
{
    return(paste0("https://rest.soilgrids.org/query?lon=", points$x, "&lat=", points$y))
}

# Downloads a JSON file from a given URL, and returns it as a numeric matrix.
# ulproperty is the field in the response to unlist, "properties" for SG and "response" for LG
GetSGMatrix = function(url, ulproperty="properties")
{
    SGData = NULL
    while (is.null(SGData))
    {
        print(paste("Downloading data from URL:", url))
        SGData = try(rjson::fromJSON(RCurl::getURL(url)))
        if (class(SGData) == "try-error")
        {
            print("Could not download the data, retrying in 30s.")
            SGData = NULL
            Sys.sleep(30)
        }
    }
    QR = unlist(SGData[[ulproperty]])
    RRow = as.numeric(QR)
    return(matrix(RRow, ncol=length(RRow), dimnames=list(NULL, names(QR))))
}


require(rgeos)
require(overpass)
require(rgdal)
require(raster)

basins = c('Indus')

# ISWEL folder for data
setwd('P:/is-wel/indus/message_indus')

for( basin in basins )
	{

	# Grab the basin boundaries
	basin.spdf = readOGR( paste( getwd(), 'input', sep = '/' ), 'Indus_bcu', verbose = FALSE )
	basin.spdf = spTransform( basin.spdf, CRS("+proj=longlat") ) # temp[which(as.character(temp$BASIN) == basin | as.character(temp$PID) == '2256'),] for Karachi basin
	basin.sp = gUnaryUnion( basin.spdf )
	basin.sp = SpatialPolygons(list(Polygons(Filter(function(f){f@ringDir==1},basin.sp@polygons[[1]]@Polygons),ID=1)))
	buff.sp = gBuffer( basin.sp, width=0.1 )
	proj4string(basin.sp) = proj4string(basin.spdf)
	proj4string(buff.sp) = proj4string(basin.spdf)

	# Grab electricity transmission data corresponding to extent from basin polygon
	rtypes = c('motorway','trunk','primary','secondary')#,'tertiary','unclassified')
	roads = lapply( rtypes, function(rtype){
		ext = paste( '(',paste(bbox(basin.spdf)[2,1] , bbox(basin.spdf)[1,1], bbox(basin.spdf)[2,2], bbox(basin.spdf)[1,2],sep=','),')',sep='')
		pth = paste( '[out:xml][timeout:100];(node["highway"="',rtype,'"]',ext,';way["highway"="',rtype,'"]',ext,';relation["highway"="',rtype,'"]',ext,';);out body;>;out skel qt;', sep = '' )
		frb = overpass_query(pth)
		if( !is.null(frb) )
			{
			proj4string(frb) = proj4string(basin.spdf)
			frb = frb[ which( unlist( row.names(frb) ) %in% unlist( sapply( unlist( row.names( gIntersection( frb, buff.sp , byid=TRUE ) ) ), function(xxx){ unlist( strsplit( xxx, '[ ]') )[1] } ) ) ), 'highway' ]
			}
		return(frb)
		} )
	names(roads) = rtypes
	roads[ sapply( roads, is.null ) ] = NULL
	roads = do.call( rbind, roads )

	# Output to shapefile
	writeOGR( roads, 'input/basin_roads', paste(basin,'osm_roads',sep='_'),  driver="ESRI Shapefile",  overwrite_layer=TRUE )

	}


rebol [
	title: "SWF sprites and movie clip related parse functions"
	purpose: "Functions for parsing sprites and movie clip related tags in SWF files"
]

;tagId: none
use-BB-optimization?: false;true
set 'swf-tag-optimize func[tagId tagData /local err action st st2][
	;tagId: tag
	reduce either none? action: select parseActions tagId [
		;tagData
		;print ["importing tag:"  tagId]
		form-tag tagId tagData
	][
		setStreamBuffer tagData
		clearOutBuffer
		;print ["IMP>" index? inBuffer length? inBuffer]
		if error? set/any 'err try [
			set/any 'result do bind/copy action 'self
			;probe bind?
		][
			print ajoin ["!!! ERROR while optimizing tag:" select swfTagNames tagId "(" tagId ")"]
			throw err
		]
		result
		;head inBuffer
		;print ["IMP<" index? inBuffer length? head inBuffer]
		;form-tag tagId head inBuffer
	]

]

optimize-detectBmpFillBounds: has[
	shape result fillStyles lineStyles pos st dx dy tmp lineStyle fillStyle0 fillStyle1 p fill
	posX posY t0x t0y s0x s0y r0x r0y t1x t1y s1x s1y r1x r1y bmpFills noCropBitmaps usedFills usedLines allUsedLines allUsedFills
	lastBmpFill
] [
	;print ["optimize-detectBmpFillBounds" tagId]
	bmpFills: copy []
	noCropBitmaps: copy []

	id:     readUI16 ;shapeID
	bounds: readRect ;shape bounds
	;print ["BOUNDS:" mold bounds]
	if tagId >= 67 [
		readRect      ;edgeBounds
		skipBytes 1   ;flags: 6*reserved,usesNonScalingStrokes,usesScalingStrokes
	]

	fillStyles: readFILLSTYLEARRAY
	lineStyles: readLINESTYLEARRAY
	byteAlign
	lineStyle: fillStyle0: fillStyle1: none
	pos: 0x0
	posX: posY: 0
	fill: fill0posX: fill1posX: fill0posY: fill1posY: fill0: fill1: none
	minX: fill0minX: fill1minX:
	minY: fill0minY: fill1minY:  100000000
	maxX: fill0maxX: fill1maxX:
	maxY: fill0maxY: fill1maxY: -100000000

	usedFills:    copy []
	usedLines:    copy []
	allUsedFills: copy []
	allUsedLines: copy []
	allBounds:    copy []

	add-BmpFill: func[id minx miny maxx maxy sx sy rx ry tx ty /local lastBmpFill][
		lastBmpFill: skip tail bmpFills -11
		either all [
			id = lastBmpFill/1
			sx = lastBmpFill/6
			sy = lastBmpFill/7
			rx = lastBmpFill/8
			ry = lastBmpFill/9
			tx = lastBmpFill/10
			ty = lastBmpFill/11
		][
			change/part next lastBmpFill reduce [
				min minX lastBmpFill/2
				min minY lastBmpFill/3
				max maxX lastBmpFill/4
				max maxY lastBmpFill/5
			] 4
		][
			repend bmpFills [id minx miny maxx maxy sx sy rx ry tx ty]
		]
	]

	numFillBits: readUB 4 ;Number of fill index bits for new styles
	numLineBits: readUB 4 ;...line...

	until [
		either readBitLogic [ ;edge?
			;print "edge"
			either readBitLogic [;straightEdge?
				;print "line - "
				nBits: 2 + readUB 4 ;original nBits - result may be different!
				;comment {
				either readBitLogic [
					;GeneralLine
					posX: posX + readSB nBits ;deltaX
					posY: posY + readSB nBits ;deltaY
				][
					either readBitLogic [
						posY: posY + readSB nBits  ;deltaY
					][	posX: posX + readSB nBits ];deltaX
				]
				if fill0posX [
					fill0posX: posX
					fill0posY: posY
					;print ["FILL0 pos:" fill0posX fill0posY]
					fill0minX: min fill0minX fill0posX
					fill0maxX: max fill0maxX fill0posX
					fill0minY: min fill0minY fill0posY
					fill0maxY: max fill0maxY fill0posY
				]
				if fill1posX [
					fill1posX: posX
					fill1posY: posY
					fill1minX: min fill1minX fill1posX
					fill1maxX: max fill1maxX fill1posX
					fill1minY: min fill1minY fill1posY
					fill1maxY: max fill1maxY fill1posY
				]
				minX: min minX posX
				maxX: max maxX posX
				minY: min minY posY
				maxY: max maxY posY
			][
				;print "curve - "
				nBits: 2 + readUB 4
				x0: posX
				y0: posY

				x1: x0 + readSB nBits ;deltaX
				y1: y0 + readSB nBits ;deltaY
				posX: x1 + readSB nBits ;deltaX
				posY: y1 + readSB nBits ;deltaY

				minY: min minY yMin: either y0 > posY [
					either y1 > posY [posY][
						t: -( y1 - y0 ) / ( posY - (2 * y1) + y0 )
						(t1: 1 - t) * t1 * y0 + (2 * t * t1 * y1) + (t * t * posY)
					]
				][
					either y1 > y0 [y0][
						t: -( y1 - y0 ) / ( posY - (2 * y1) + y0 )
						(t1: 1 - t) * t1 * y0 + (2 * t * t1 * y1) + (t * t * posY)
					]
				]
				maxY: max maxY yMax: either y0 > posY [
					either y1 < y0 [y0][
						t: -( y1 - y0 ) / ( posY - (2 * y1) + y0 )
						(t1: 1 - t) * t1 * y0 + (2 * t * t1 * y1) + (t * t * posY)
					]
				][
					either posY > y1 [posY][
						t: -( y1 - y0 ) / ( posY - (2 * y1) + y0 )
						(t1: 1 - t) * t1 * y0 + (2 * t * t1 * y1) + (t * t * posY)
					]
				]
				minX: min minX xMin: either x0 > posX [
					either x1 > posX [posX][
						t: -( x1 - x0 ) / ( posX - (2 * x1) + x0 )
						(t1: 1 - t) * t1 * x0 + (2 * t * t1 * x1) + (t * t * posX)
					]
				][
					either x1 > x0 [x0][
						t: -( x1 - x0 ) / ( posX - (2 * x1) + x0 )
						(t1: 1 - t) * t1 * x0 + (2 * t * t1 * x1) + (t * t * posX)
					]
				]
				maxX: max maxX xMax: either x0 > posX [
					either x1 < x0 [x0][
						t: -( x1 - x0 ) / ( posX - (2 * x1) + x0 )
						(t1: 1 - t) * t1 * x0 + (2 * t * t1 * x1) + (t * t * posX)
					]
				][
					either x1 < posX [posX][
						t: -( x1 - x0 ) / ( posX - (2 * x1) + x0 )
						(t1: 1 - t) * t1 * x0 + (2 * t * t1 * x1) + (t * t * posX)
					]
				]

				;print ["-" x0 y0 x1 y1 posX posY xMin yMin xMax yMax]

				if fill0posX [
					fill0posX: posX
					fill0posY: posY
					;print ["FILL0 pos:" fill0posX fill0posY]
					fill0minX: min fill0minX xMin
					fill0maxX: max fill0maxX xMax
					fill0minY: min fill0minY yMin
					fill0maxY: max fill0maxY yMax
				]
				if fill1posX [
					fill1posX: posX
					fill1posY: posY
					fill1minX: min fill1minX xMin
					fill1maxX: max fill1maxX xMax
					fill1minY: min fill1minY yMin
					fill1maxY: max fill1maxY yMax
				]

			]

			false
		][
			states: readUB 5
			;print ["STATES" mold states fill0posX]
			either states = 0 [;EndShapeRecord
				byteAlign
				true ;end
			][	;StyleChangeRecord
				if 0 < (states and 1 ) [;move
					set [posX posY] readSBPair
					if 0 = (states and 16) [
						minX: min minX posX
						maxX: max maxX posX
						minY: min minY posY
						maxY: max maxY posY
					]
				]
				prevFill0: fillStyle0
				prevFill1: fillStyle1
				fill0: fill1: none
				if 0 < (states and 2 ) [ ;fillStyle0
					fillStyle0: either fill0: readUB numFillBits [
						either fill0 > 0 [
							append usedFills fill0
							pick fillStyles fill0
						][	none ]
					][ none ]
				]
				if 0 < (states and 4 ) [ ;fillStyle1
					fillStyle1: either fill1: readUB numFillBits [
						either fill1 > 0 [
							append usedFills fill1
							pick fillStyles fill1
						][	none ]
					][ none ]
				]
				if 0 < (states and 8 ) [ ;lineStyle
					lineStyle: either tmp: readUB numLineBits [
						either tmp > 0 [
							append usedLines tmp
							pick lineStyles tmp
						][	none ]
					][ none ]
				]

				if fillStyle0 <> prevFill0 [
					if all [prevFill0 find [64 65 66 67] prevFill0/1 not none? fill0][
						;print ["end fill0-" fill0posX fill0posY]
						add-BmpFill prevFill0/2/1 fill0minX fill0minY fill0maxX fill0maxY s0x s0y r0x r0y t0x t0y
					]
					either all [
						fillStyle0
						find [64 65 66 67] fillStyle0/1
					][
						tmp: fillStyle0/2/2
						t0x: tmp/3/1
						t0y: tmp/3/2
						either tmp/2 [
							r0x: tmp/2/1
							r0y: tmp/2/2
						][
							r0x: r0y: 0
						]
						either tmp/1 [
							s0x: tmp/1/1
							s0y: tmp/1/2
						][
							s0x: s0y: 0
						]
						fill0posX: posX
						fill0posY: posY
						fill0minX: fill0minY:  100000000
						fill0maxX: fill0maxY: -100000000
					][
						t0x: t0y: r0x: r0y: s0x: s0y:
						fill0posX: fill0posY: none
					]
				]
				if fillStyle1 <> prevFill1 [
					if all [prevFill1 find [64 65 66 67] prevFill1/1 not none? fill1][
						;print ["end fill1-" fill1posX fill1posY]
						add-BmpFill prevFill1/2/1 fill1minX fill1minY fill1maxX fill1maxY s1x s1y r1x r1y t1x t1y
					]
					either all [
						fillStyle1
						find [64 65 66 67] fillStyle1/1
					][
						tmp: fillStyle1/2/2
						t1x: tmp/3/1
						t1y: tmp/3/2
						either tmp/2 [
							r1x: tmp/2/1
							r1y: tmp/2/2
						][
							r1x: r1y: 0
						]
						either tmp/1 [
							s1x: tmp/1/1
							s1y: tmp/1/2
						][
							s1x: s1y: 0
						]
						fill1posX: posX
						fill1posY: posY
						fill1minX: fill1minY:  100000000
						fill1maxX: fill1maxY: -100000000
					][
						t1x: t1y: r1x: r1y: s1x: s1y:
						fill1posX: fill1posY: none
					]
				]

				if fill0posX [
					fill0minX: min fill0minX fill0posX
					fill0maxX: max fill0maxX fill0posX
					fill0minY: min fill0minY fill0posY
					fill0maxY: max fill0maxY fill0posY
				]
				if fill1posX [
					fill1minX: min fill1minX fill1posX
					fill1maxX: max fill1maxX fill1posX
					fill1minY: min fill1minY fill1posY
					fill1maxY: max fill1maxY fill1posY
				]

				;print ["fillStyle0:" mold fillStyle0]
				;print ["fillStyle1:" mold fillStyle1]
				;probe fillStyle0
				;ask "aaa"

				if 0 < (states and 16) [
					;print "2XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"

					repend/only allUsedFills [
						copy/deep fillStyles
						copy sort unique usedFills
					]
					repend/only allUsedLines [
						copy/deep lineStyles
						copy sort unique usedLines
					]
					append/only allBounds reduce [to-integer minX round maxX to-integer minY round maxY]

					clear head usedFills
					clear head usedLines

					byteAlign
					fillStyles: readFILLSTYLEARRAY
					lineStyles: readLINESTYLEARRAY

					prevFill0: prevFill1: lineStyle: fillStyle0: fillStyle1: none
					pos: 0x0
					posX: posY: 0
					fill: fill0posX: fill1posX: fill0posY: fill1posY: fill0: fill1: none
					minX: fill0minX: fill1minX:
					minY: fill0minY: fill1minY:  100000000
					maxX: fill0maxX: fill1maxX:
					maxY: fill0maxY: fill1maxY: -100000000

					numFillBits: readUB 4 ;Number of fill index bits for new styles
					numLineBits: readUB 4 ;...line...
				] ;NewStyles

				false ;continue
			]
		]
	]

	if all [fill0posX fillStyle0 find [64 65 66 67] fillStyle0/1][
		;print ["end fill0-" fill0posX fill0posY]
		add-BmpFill fillStyle0/2/1 fill0minX fill0minY fill0maxX fill0maxY s0x s0y r0x r0y t0x t0y
	]
	if all [fill1posX fillStyle1 find [64 65 66 67] fillStyle1/1] [
		;print ["end fill1-" fill1posX fill1posY]
		add-BmpFill fillStyle1/2/1 fill1minX fill1minY fill1maxX fill1maxY s1x s1y r1x r1y t1x t1y
	]

	;print ["bmpFills" mold bmpFills]

;	bmpFills: copy []
;	foreach fill fillStyles [
;		if find [64 65 66 67] fill/1 [
;			repend bmpFills probe reduce [fill/2/1 fill/2/2/3  fill/3 fill/4 fill/5 fill/6]
;		]
;	]

	repend/only allUsedFills [
		copy/deep fillStyles
		copy sort unique usedFills
	]
	repend/only allUsedLines [
		copy/deep lineStyles
		copy sort unique usedLines
	]
	append/only allBounds reduce [to-integer minX round maxX to-integer minY round maxY]

	clear usedLines
	clear usedFills

;===============================================================================
comment {
	shape: parse-DefineShape
	;print length? shape
	;ask ""
	;print "-=-=-=-"
	fillStyles: shape/4/1

	lineStyles: shape/4/2
	lineStyle: fillStyle0: fillStyle1: none
	pos: 0x0
	posX: posY: 0
	fill: fill0posX: fill1posX: fill0posY: fill1posY: none
	minX: fill0minX: fill1minX:
	minY: fill0minY: fill1minY:  100000000
	maxX: fill0maxX: fill1maxX:
	maxY: fill0maxY: fill1maxY: -100000000

	allUsedFills: copy []
	usedFills: copy []
	usedLines: copy []
	allUsedLines: copy []
	allBounds: copy []

	parse shape/4/3 [
		any [
			'style set st block! p: (
				;print ["style:" mold st]
				if all [st/2 st/2 > 0] [append usedFills st/2]
				if all [st/3 st/3 > 0] [append usedFills st/3]
				if all [st/4 st/4 > 0] [append usedLines st/4]
				;ask ""
				if all [fill0posX fill0bmp find [64 65 66 67] fill0bmp/1 not none? st/2] [
					;print ["end fill0-" fill0posX fill0posY]
					repend bmpFills reduce [fill0bmp/2/1 fill0minX fill0minY fill0maxX fill0maxY s0x s0y r0x r0y t0x t0y]
					fill0bmp: none
				]
				if all [fill1posX fill1bmp find [64 65 66 67] fill1bmp/1 not none? st/3] [
					;print ["end fill1-" fill1posX fill1posY]
					repend bmpFills reduce [fill1bmp/2/1 fill1minX fill1minY fill1maxX fill1maxY s1x s1y r1x r1y t1x t1y]
					fill1bmp: none
				]
				;smazat?-> if fill1pos [fill1pos: fill1pos + as-pair dx dy]
				fill0bmp: either fill0: st/2 [fillStyles/(fill0)][none]
				fill1bmp: either fill1: st/3 [fillStyles/(fill1)][none]
				if st/1 [
					posX: st/1/1
					posY: st/1/2
					minX: min minX posX
					maxX: max maxX posX
					minY: min minY posY
					maxY: max maxY posY
				]
				;print ["POS:" posX posY]
				either any [
					all [fill0bmp find [64 65 66 67] fill0bmp/1]
					all [fill1bmp find [64 65 66 67] fill1bmp/1]
				][
				;	print ["bmpfill" mold fill0bmp mold fill1bmp]
					;if fill0bmp [print ["????????????????????????" fill0bmp/2/1 fill0bmp/1]]
					;if fill1bmp [print ["????????????????????????" fill1bmp/2/1 fill1bmp/1]]
					either all [
						fill0bmp
						find [64 65 66 67] fill0bmp/1
					][
					;	probe fillStyles
						tmp: fill0bmp/2/2

						t0x: tmp/3/1
						t0y: tmp/3/2
						either tmp/2 [
							r0x: tmp/2/1
							r0y: tmp/2/2
						][
							r0x: r0y: 0
						]
						either tmp/1 [
							s0x: tmp/1/1
							s0y: tmp/1/2
						][
							s0x: s0y: 0
						]
						fill0posX: posX ;(posX * s0x) + (posY * r0y) + t0x
						fill0posY: posY ;(posY * s0y) + (posX * r0x) + t0y
						fill0minX: fill0minY:  100000000
						fill0maxX: fill0maxY: -100000000
					][
						t0x: t0y: r0x: r0y: s0x: s0y:
						fill0posX: fill0posY: none
					]
					either all [fill1bmp find [64 65 66 67] fill1bmp/1] [
						tmp: fill1bmp/2/2

						t1x: tmp/3/1
						t1y: tmp/3/2
						either tmp/2 [
							r1x: tmp/2/1
							r1y: tmp/2/2
						][
							r1x: r1y: 0
						]
						either tmp/1 [
							s1x: tmp/1/1
							s1y: tmp/1/2
						][
							s1x: s1y: 1
						]
						fill1posX: posX ;(posX * s1x) + (posY * r1y) + t1x
						fill1posY: posY ;(posY * s1y) + (posX * r1x) + t1y
						fill1minX: fill1minY:  100000000
						fill1maxX: fill1maxY: -100000000
					][
						t1x: t1y: r1x: r1y: s1x: s1y:
						fill1posX: fill1posY: none
					]

					;print ["FILL0:" fill0posX fill0posY t0x t0y s0x s0y r0x r0y]
					;print ["FILL1:" fill1posX fill1posY t1x t1y s1x s1y r1x r1y]

					if fill0posX [
						;print ["fill0pos" fill0posX fill0posY]
						fill0minX: min fill0minX fill0posX
						fill0maxX: max fill0maxX fill0posX
						fill0minY: min fill0minY fill0posY
						fill0maxY: max fill0maxY fill0posY
						print ["??" fill0minX fill0minY ]
					]
					if fill1posX [
						fill1minX: min fill1minX fill1posX
						fill1maxX: max fill1maxX fill1posX
						fill1minY: min fill1minY fill1posY
						fill1maxY: max fill1maxY fill1posY
					]
				][
					;print "nobmpfill"
					either tmp: find p 'style [p: tmp][p: tail p]
				]

				if st/5 [
					repend/only allUsedFills [
						copy/deep fillStyles
						copy sort unique usedFills
					]
					repend/only allUsedLines [
						copy/deep lineStyles
						copy sort unique usedLines
					]
					append/only allBounds reduce [minX maxX minY maxY]

					clear head usedFills
					clear head usedLines

					;print ["new fillStyles:" mold st/5/1]
					;ask ""
					;new-style
					fillStyles: st/5/1
					lineStyles: st/5/2
					lineStyle: fillStyle0: fillStyle1: none
					pos: 0x0
					posX: posY: 0
					fill: fill0posX: fill1posX: fill0posY: fill1posY: none
					minX: fill0minX: fill1minX:
					minY: fill0minY: fill1minY:  100000000
					maxX: fill0maxX: fill1maxX:
					maxY: fill0maxY: fill1maxY: -100000000
				]
			) :p
			| 'line some [
				set dx integer! set dy integer! (
					posX: posX + dx
					posY: posY + dy
					if fill0posX [
						fill0posX: posX ;(posX * s0x) + (posY * r0y) + t0x
						fill0posY: posY ;(posY * s0y) + (posX * r0x) + t0y
						;print ["FILL0 pos:" fill0posX fill0posY]
						fill0minX: min fill0minX fill0posX
						fill0maxX: max fill0maxX fill0posX
						fill0minY: min fill0minY fill0posY
						fill0maxY: max fill0maxY fill0posY
					]
					if fill1posX [
						fill1posX: posX ;(posX * s1x) + (posY * r1y) + t1x
						fill1posY: posY ;(posY * s1y) + (posX * r1x) + t1y
						fill1minX: min fill1minX fill1posX
						fill1maxX: max fill1maxX fill1posX
						fill1minY: min fill1minY fill1posY
						fill1maxY: max fill1maxY fill1posY
					]
					minX: min minX posX
					maxX: max maxX posX
					minY: min minY posY
					maxY: max maxY posY
				)]
			|
			'curve some [
				;set cx integer! set cy integer!
				set dx integer! set dy integer! (
					posX: posX + dx
					posY: posY + dy
					if fill0posX [
						fill0posX: posX ;(posX * s0x) + (posY * r0y) + t0x
						fill0posY: posY ;(posY * s0y) + (posX * r0x) + t0y
						fill0minX: min fill0minX fill0posX
						fill0maxX: max fill0maxX fill0posX
						fill0minY: min fill0minY fill0posY
						fill0maxY: max fill0maxY fill0posY
					]
					if fill1posX [
						fill1posX: posX ;(posX * s1x) + (posY * r1y) + t1x
						fill1posY: posY ;(posY * s1y) + (posX * r1x) + t1y
						fill1minX: min fill1minX fill1posX
						fill1maxX: max fill1maxX fill1posX
						fill1minY: min fill1minY fill1posY
						fill1maxY: max fill1maxY fill1posY
					]
					minX: min minX posX
					maxX: max maxX posX
					minY: min minY posY
					maxY: max maxY posY
				)
			]
		]
	]
	if all [fill0posX fill0bmp] [
		;print ["end fill0" fill0posX fill0posY]
		repend bmpFills reduce [fill0bmp/2/1 fill0minX fill0minY fill0maxX fill0maxY s0x s0y r0x r0y t0x t0y]

	]
	if all [fill1posX fill1bmp] [
		;print ["end fill1" fill1posX fill1posY]
		repend bmpFills reduce [fill1bmp/2/1 fill1minX fill1minY fill1maxX fill1maxY s1x s1y r1x r1y t1x t1y]

	]

	;probe fill0bmp
print ["bmpFills" mold bmpFills]

;	bmpFills: copy []
;	foreach fill fillStyles [
;		if find [64 65 66 67] fill/1 [
;			repend bmpFills probe reduce [fill/2/1 fill/2/2/3  fill/3 fill/4 fill/5 fill/6]
;		]
;	]

	repend/only allUsedFills [
		copy/deep fillStyles
		copy sort unique usedFills
	]
	repend/only allUsedLines [
		copy/deep lineStyles
		copy sort unique usedLines
	]
	append/only allBounds reduce [minX maxX minY maxY]

	clear usedLines
	clear usedFills

	;print "======"
	;probe allUsedFills
	;probe allUsedLines
	;ask ""

	;print ["usedFills:" length? allUsedFills tab mold allUsedFills]
	;ask ""
	}
	;===============================================================================
	reduce [
		bmpFills
		id
		context compose/only [
			fills: (new-line allUsedFills true)
			lines: (new-line allUsedLines true)
			bounds: (allBounds)
		]
	]
]

optimize-updateShape: has [id bounds styles fillsMap linesMap end?][
	id: carryUI16 ;shapeID
	;	print ["SH" id tagId "\"]

	writeRect bounds: readRect ;shape bounds
	;print ["BOUNDS:" mold bounds]
	if tagId >= 67 [
		writeRect readRect ;edgeBounds
		carryBytes 1    ;flags: 6*reserved,usesNonScalingStrokes,usesScalingStrokes
	]
	alignBuffers

	styles: select data/shapeStyles id
	fillsMap: optimize-processFills styles/fills/1/2
	linesMap: optimize-processLines styles/lines/1/2

	;ask ""

	numFillBits: carryUB 4
	numLineBits: carryUB 4
	end?: false

	until [
		;test if can use BBShape
		;ask "TESTING IF BB"
		either all [
			false
			use-BB-optimization?
			empty? linesMap
			1 = length? fillsMap ;= only one fill used
			tmp: pick styles/fills/1/1 fillsMap/1
			find [64 65 66] tmp/1 ;= optimize only bitmaps with transparency
			find [35 36] first select swfBitmaps tmp/2/1
			none? find data/noBBids tmp/2/1
		][

			;can simplify shape..skip source and write BB shape at the end
			;ask "simplify BB.."
			until [
				either readBitLogic [ ;edge?
					either readBitLogic [;straightEdge?
						nBits: 2 + readUB 4 ;original nBits - result may be different!
						either readBitLogic [
							skipBits (2 * nBits) ;GeneralLine
						][	skipBits (1 + nBits)]
					][
						skipBits (4 * (2 + readUB 4))
					]
					false
				][
					states: readUB 5
					;ask reform ["states:" states]
					either states = 0 [
						;EndShapeRecord
						optimize-writeBBshape styles/bounds/1
						writeBit false
						writeUB 0 5
						alignBuffers
						end?:
						true ;end
					][
						;StyleChangeRecord
						;print ["STYLE CHANGE1:"]
						either 0 < (states and 16) [ ;NewStyles
							optimize-writeBBshape styles/bounds/1
							writeBit false
							writeUB states 5
							if 0 < (states and 1 ) [carrySBPair];move
							if 0 < (states and 2 ) [
								writeUB either 0 < tmp: readUB numFillBits [index? find fillsMap tmp][0] numFillBits
							] ;fillStyle0
							if 0 < (states and 4 ) [
								writeUB either 0 < tmp: readUB numFillBits [index? find fillsMap tmp][0] numFillBits
							] ;fillStyle1
							if 0 < (states and 8 ) [
								writeUB either 0 < tmp: readUB numLineBits [index? find linesMap tmp][0] numLineBits
							];lineStyle

							;print "1XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
							;probe states
							;ask ""

							alignBuffers
							styles/fills:  next styles/fills
							styles/lines:  next styles/lines
							styles/bounds: next styles/bounds

							fillsMap: optimize-processFills styles/fills/1/2
							linesMap: optimize-processLines styles/lines/1/2

							numFillBits: carryUB 4 ;Number of fill index bits for new styles
							numLineBits: carryUB 4 ;...line...
							break ;continue in main loop
						][
							if 0 < (states and 1 ) [
								skipSBPair
							];move
							if 0 < (states and 2 ) [ skipBits numFillBits] ;fillStyle0
							if 0 < (states and 4 ) [ skipBits numFillBits] ;fillStyle1
							if 0 < (states and 8 ) [ skipBits numLineBits] ;lineStyle

						]
						false ;continue
					]
				]
			]
		][
			;cannot simplify this shape..so just reuse it
			until [
				either carryBitLogic [ ;edge?
			;		print "edge"
					either carryBitLogic [;straightEdge?
						;print "line - "
						nBits: 2 + carryUB 4 ;original nBits - result may be different!
						;comment {
						either carryBitLogic [
							;GeneralLine
							carrySB nBits ;deltaX
							carrySB nBits ;deltaY
						][
							carryBitLogic
							carrySB nBits
						]
					][
						;print "curve - "
						nBits: 2 + carryUB 4
						carrySB nBits ;controlDeltaX
						carrySB nBits ;Y
						carrySB nBits ;anchorDeltaX
						carrySB nBits ;Y
					]
					false
				][
					states: carryUB 5
					;print ["STATES" mold states]
					either states = 0 [
						;EndShapeRecord
						alignBuffers
						end?:
						true ;end
					][
						;StyleChangeRecord
						;print ["STYLE CHANGE2:" ]
						if 0 < (states and 1 ) [
					;		prin "Move "
							carrySBPair
						]      ;move
						if 0 < (states and 2 ) [
							writeUB either 0 < tmp: readUB numFillBits [index? find fillsMap tmp][0] numFillBits
						] ;fillStyle0
						if 0 < (states and 4 ) [
							writeUB either 0 < tmp: readUB numFillBits [index? find fillsMap tmp][0] numFillBits
						] ;fillStyle1
						if 0 < (states and 8 ) [
							writeUB either 0 < tmp: readUB numLineBits [index? find linesMap tmp][0] numLineBits
						];lineStyle
						if 0 < (states and 16) [
							;print "2XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
							;probe states
							;ask ""

							alignBuffers
							styles/fills:  next styles/fills
							styles/lines:  next styles/lines
							styles/bounds: next styles/bounds

							fillsMap: optimize-processFills styles/fills/1/2
							linesMap: optimize-processLines styles/lines/1/2

							numFillBits: carryUB 4 ;Number of fill index bits for new styles
							numLineBits: carryUB 4 ;...line...
							break ;continue in main loop
						] ;NewStyles

						false ;continue
					]
				]
			]
		]

		end?
	]
	;ask "end"

	comment {
	foreach fill usedFills [
		print "+++++++++++++++++++"
		probe fill
		writeUI8 type: fill/1
		case  [
			type = 0 [
				;solid fill
				case [
					find [46 84] tagId [
						;morph
						writeRGBA fill/2/1
						writeRGBA fill/2/2
					]
					tagId >= 32 [writeRGBA fill/2]
					true [writeRGB fill/2]
				]
			]
			any [
				type = 16 ;linear gradient fill
				type = 18 ;radial gradient fill
				type = 19 ;focal gradient fill (swf8)
			][
				;gradient
				either find [46 84] tagId [
					;morph
					writeMATRIX   fill/2/1
					writeMATRIX   fill/2/2
					writeGRADIENT fill/2/3 type
				][	;shape
					writeMATRIX   fill/2/1
					writeGRADIENT fill/2/2 type
				]
			]
			type >= 64 [
				;bitmap
				reduce either find [46 84] tagId [
					;morph
					writeUI16 fill/2/1
					writeMATRIX   fill/2/2
					writeMATRIX   fill/2/3
				][	;shape
					writeUI16 fill/2/1
					writeMATRIX   fill/2/2
				]
			]
		]
	]
	;zapsal jsem pouze pouzite fills
	}

	;alignBuffers
	;optimizeLINESTYLEARRAY
	;alignBuffers

	;optimize-shapeRecord id bounds (alignBuffers carryUB 4) carryUB 4
	alignBuffers
	;insert tail outBuffer copy inBuffer
	data/shapeReduction: data/shapeReduction + (length? head inBuffer) - length? head outBuffer
	head outBuffer
]

optimize-processLines: func[usedLineIds /local linesMap i LineStyles joinStyle hasFill?][
	alignBuffers

	linesMap: copy []
	writeCount length? usedLineIds
	i: 0
	loop readCount [
		alignBuffers
		;print ["????" i mold usedLineIds]
		either find usedLineIds i: i + 1 [
			append linesMap i
			optimizeLINESTYLE
		][
			skipLINESTYLE
		]
	]
	alignBuffers
	linesMap
]

optimize-processFills: func[usedFillIds /local i fillMap type id][
	fillMap: copy []
	writeCount length? usedFillIds
	i: 0
	loop readCount [
		alignBuffers
		either find usedFillIds i: i + 1 [
			append fillMap i
			optimizeFILLSTYLE
		][;UNUSED FILL = skipping!
			skipFILLSTYLE
		]
	]
	alignBuffers
	fillMap
]

optimize-writeBBshape: func[bounds /local minx miny maxx maxy][
	set [minx maxx miny maxy] bounds
	print reform ["USING BBShape" mold bounds]
	writeBit false
	writeUB 3 5
	writeSBPair reduce [minx miny] ;-1040 -1480 880 1400
	writeUB 1 numFillBits

	writeBit true
	writeBit true ;straightEdge
	writeUB (nBits: to integer! log-2 tmp: (maxx - minx)) 4
	nBits: nBits + 2
	writeBit false
	writeBit false ;horiz
	writeSB tmp nBits

	writeBit true
	writeBit true ;straightEdge
	writeUB (nBits: to integer! log-2 tmp: (maxy - miny)) 4
	nBits: nBits + 2
	writeBit false
	writeBit true ;vert
	writeSB tmp nBits

	writeBit true
	writeBit true ;straightEdge
	writeUB (nBits: to integer! log-2 abs tmp: (minx - maxx)) 4
	nBits: nBits + 2
	writeBit false
	writeBit false ;horiz
	writeSB tmp nBits

	writeBit true
	writeBit true ;straightEdge
	writeUB (nBits: to integer! log-2 abs tmp: (miny - maxy)) 4
	nBits: nBits + 2
	writeBit false
	writeBit true ;vert
	writeSB tmp nBits
	;print ["done.." bounds]
]

updateCombinedBmpMATRIX: func[id /local ofs sc ro pos][
	either ofs: select data/combined-bitmaps id [
		;print ["updateBmpMATRIX" id "to:" ofs]
		alignBuffers
		either carryBitLogic [;scale
			writePair sc: readPair
		][	sc: 0x0 ]
		either carryBitLogic [;rotate
			writePair ro: readPair
		][	ro: 0x0 ]
		pos: readSBPair
		;probe ofs: 20 * ofs
		;ask ""
		;print [sc ro pos]
		writeSBPair probe reduce [
		;	pos/1 - (ofs/x)
		;	pos/2 - (ofs/y)
			round (pos/1 - ((ofs/x * sc/1) + (ofs/y * ro/2)))
			round (pos/2 - ((ofs/y * sc/2) + (ofs/x * ro/1)))
		]
		alignBuffers
	][
		carryMATRIX
	]
]
updateBmpMATRIX: func[id /local size pos sc ro][
	either any [
		none? size: select data/crops id
	;	all [size/1 = 0 size/2 = 0]
	][
		carryMATRIX
	][
		alignBuffers
		either carryBitLogic [;scale
			writePair sc: readPair
		][	sc: 0x0 ]
		either carryBitLogic [;rotate
			writePair ro: readPair
		][	ro: 0x0 ]
		pos: readSBPair

		writeSBPair reduce [
			round (pos/1 + ((size/5 * sc/1) + (size/6 * ro/2)))
			round (pos/2 + ((size/6 * sc/2) + (size/5 * ro/1))) ;- 30 ;((pos/2 / sc/2) * 20)
		]
		alignBuffers
	]
]

optimizeFILLSTYLE: has[type id newid][
	alignBuffers
	writeUI8 type: readUI8 ;FillStyleType
	;print ["optimizeFILLSTYLE..." type tagId]
	case [
		type = 0 [
			;solid fill
			case [
				find [46 84] tagId [
					carryBytes 8 ;morph RGBAs
				]
				tagId >= 32 [carryBytes 4] ;RGBA
				true [carryBytes 3] ;RGB
			]
		]
		any [
			type = 16 ;linear gradient fill
			type = 18 ;radial gradient fill
			type = 19 ;focal gradient fill (swf8)
		][
			;gradient
			;print "gradient.."
			either find [46 84] tagId [
				;morph
				carryMATRIX
				carryMATRIX
				byteAlign
				;MORPHGRADIENT:
				loop carryUI8 [
					carryBytes 10 ;Start ratio,Start color,End ratio,End color
				]
			][	;shape
				;print "./......................."
				carryMATRIX
				byteAlign
				;GRADIENT:
				carryBits 4 ;SpreadMode + InterpolationMode
				loop carryUB 4 [
					;GRADRECORD
					carryBytes either tagId >= 32 [5][4] ;ratio + color
				]
				if all [type = 19 tagId = 83] [carryBytes 2] ;FocalPoint
			]
			;print "//"
		]
		type >= 64 [
			;bitmap
			reduce either find [46 84] tagId [
				;morph
				id: readUI16
				either find first data 'combined-bitmaps [
					either find data/combined-bitmaps id [
						writeUI16 data/combined-bmp-id
						updateCombinedBmpMATRIX id
						updateCombinedBmpMATRIX id
					][
						writeUI16 id
						carryMATRIX
						carryMATRIX
					]
				][
					writeUI16 id
					updateBmpMATRIX id
					updateBmpMATRIX id
				]

			][	;shape
				id: readUI16
				either find first data 'combined-bitmaps [
					either find data/combined-bitmaps id [
						writeUI16 data/combined-bmp-id
						updateCombinedBmpMATRIX id
					][
						writeUI16 id
						carryMATRIX
					]

				][
					writeUI16 id
					updateBmpMATRIX id
				]
			]
		]
	]
]
optimizeLINESTYLE: has[joinStyle hasFill?][
	alignBuffers
	case [
		;DefineMorphShape
		tagId = 46 [
			carryBytes 12 ;StartWidth, EndWidth, RGBA + RGBA
		]
		;DefineShape4
		any [tagId = 67 tagId = 83][
			carryBytes 2   ;Width
			carryBits  2              ;f_start_cap_style
			joinStyle: carryUB 2     ;f_join_style
			hasFill?:  carryBitLogic ;f_has_fill
			carryBits 11 ;f_no_hscale,f_no_vscale,f_pixel_hinting,5*reserved,f_no_close,2*f_end_cap_style

			if joinStyle = 2 [carryBytes 2] ;miterLimit
			either hasFill? [optimizeFILLSTYLE][carryBytes 4]
		]
		;DefineMorphShape2
		tagId = 84 [
			carryBytes 4 ;StartWidth, EndWidth
			carryBits 2              ;f_start_cap_style
			joinStyle: carryUB 2     ;f_join_style
			hasFill?:  carryBitLogic ;f_has_fill
			carryBits 11 ;f_no_hscale,f_no_vscale,f_pixel_hinting,5*reserved,f_no_close,2*f_end_cap_style

			if joinStyle = 2 [carryBytes 2] ;miterLimit
			either hasFill? [optimizeFILLSTYLE][carryBytes 8]
		]
		true [
			carryBytes either tagId = 32 [6][5]
		]
	];case
]
skipFILLSTYLE: has [type id][
	alignBuffers
	type: readUI8 ;FillStyleType
	;print ["optimizeFILLSTYLE..." type tagId]
	case [
		type = 0 [
			;solid fill
			case [
				find [46 84] tagId [
					skipBytes 8 ;morph RGBAs
				]
				tagId >= 32 [skipBytes 4] ;RGBA
				true [skipBytes 3] ;RGB
			]
		]
		any [
			type = 16 ;linear gradient fill
			type = 18 ;radial gradient fill
			type = 19 ;focal gradient fill (swf8)
		][
			;gradient
			either find [46 84] tagId [
				;morph
				readMATRIX
				readMATRIX
				byteAlign
				;MORPHGRADIENT:
				loop readUI8 [
					skipBytes 10 ;Start ratio,Start color,End ratio,End color
				]
			][	;shape
				readMATRIX
				;GRADIENT:
				byteAlign
				skipBits 4 ;SpreadMode + InterpolationMode
				loop readUB 4 [
					;GRADRECORD
					skipBytes either tagId >= 32 [5][4] ;ratio + color
				]
				if all [type = 19 tagId = 83] [skipBytes 2] ;FocalPoint
			]
		]
		type >= 64 [
			;bitmap
			reduce either find [46 84] tagId [
				;morph
				skipUI16
				readMATRIX
				readMATRIX
			][	;shape
				skipUI16
				readMATRIX
			]
		]
	]
]
skipLINESTYLE: has[][
	alignBuffers
	case [
		;DefineMorphShape
		tagId = 46 [
			skipBytes 12 ;StartWidth, EndWidth, RGBA + RGBA
		]
		;DefineShape4
		any [tagId = 67 tagId = 83][
			skipBytes 2   ;Width
			skipBits  2              ;f_start_cap_style
			joinStyle: readUB 2     ;f_join_style
			hasFill?:  readBitLogic ;f_has_fill
			skipBits 11 ;f_no_hscale,f_no_vscale,f_pixel_hinting,5*reserved,f_no_close,2*f_end_cap_style

			if joinStyle = 2 [skipBytes 2] ;miterLimit
			either hasFill? [skipFILLSTYLE][skipBytes 4]
		]
		;DefineMorphShape2
		tagId = 84 [
			skipBytes 4 ;StartWidth, EndWidth
			skipyBits 2              ;f_start_cap_style
			joinStyle: readUB 2     ;f_join_style
			hasFill?:  readBitLogic ;f_has_fill
			skipBits 11 ;f_no_hscale,f_no_vscale,f_pixel_hinting,5*reserved,f_no_close,2*f_end_cap_style

			if joinStyle = 2 [skipBytes 2] ;miterLimit
			either hasFill? [skipFILLSTYLE][skipBytes 8]
		]
		true [
			skipBytes either tagId = 32 [6][5]
		]
	];case
]


#!/usr/bin/env Rscript
#Function: Train a species model(spectrum Kernel, k=5), perform 10 cross validation and output the scores. Default class size ration is 10.
#Usage:./cross_validation.r <species_name> <species_seqfile> <pos_num>

args <- commandArgs(trailingOnly = TRUE)
s <- args[1]
s_fh <- args[2]
s_posN <- as.integer(args[3])

library(caret)
library(kebabs)

dna <- readDNAStringSet(s_fh)
labels <- rep.int(1, times=s_posN) #number of human enhancers
labels_neg <- rep.int(-1, times=length(dna)-s_posN) # number of negative regions
labels_all <- c(labels, labels_neg)
numSamples <- sample(1:length(dna))
flds <- createFolds(numSamples, k=10)

wts <- 10/c(1, 10)
names(wts) <- c(1,-1)
specK5 <- spectrumKernel(k=5, revComplement=FALSE)

for ( n in 1:10) {

test <- flds[[n]]
train <- c(1:length(dna))[-test]

model <- kbsvm(x=dna[train], y=labels_all[train], kernel=specK5, pkg="LibLineaR", svm="C-svc", cost=15, perfParameters="ALL", classWeights=wts)
#extract feature weights of the model
fw <- t(sort(as.data.frame(featureWeights(model))))
out_name <- sprintf("%s_model_highweightkmers_run%s_%s.tsv",s,n,Sys.Date())
cat("Writing the feature weights to ", out_name)
write.table(fw, file=out_name,sep="\t")

  if ( n == 1 ) {
  names <- names(dna[test])
  true_labels <- labels_all[test]
  response <- predict(model, dna[test], raw=True, predictionType="response")
  decision <- predict(model, dna[test], raw=True, predictionType="decision")
  fold <- rep.int(n, times=length(test))
  } else {
  names <- c(names, names(dna[test]))
  true_labels <- c(true_labels, labels_all[test])
  response <- c(response, predict(model, dna[test], raw=True, predictionType="response"))
  temp <- predict(model, dna[test], raw=True, predictionType="decision")
  decision <- c(decision, temp)
  rocdata <- computeROCandAUC(temp, labels_all[test], unique(labels_all[test]))
  fold <- c(fold, rep.int(n, times=length(test)))
  }

}

out_df <- data.frame(names, true_labels,response, decision, fold)
out_name <- sprintf("%s_cv_scores_%s.tsv", s, Sys.Date())
cat("Writing cross validation scores to ", out_name)
write.table(out_df, file=out_name, sep="\t", row.names=FALSE)


# get_df.Datos_CESENS es un wrapper específico creado para las funciones de enfermedades
get_df.Datos_CESENS <- function(IDUbicacion, metrica, fechaInicio, fechaFin = NA, ajustarSegundos = TRUE, toUTC = TRUE)
{

	res <- get_df.Data_CESENS(token = tokenCESENS, locID = IDUbicacion, metricID = metrica,
								startDate = as.POSIXct(fechaInicio), endDate = as.POSIXct(fechaFin),
								leapSeconds = ajustarSegundos, toUTC)
	names(res) <- c("fecha", "datos")
	return(res)
}

## buscaPrimer00 se usa en los cálculos de los datos horarios, para eliminar los registros que pueda haber al principio de la df.datosEnfermedades que no sean de las xx:00
buscaPrimer00 <- function(res){
	filasRes = nrow(res)

	repeat{
		if(nrow(res) == 0) break
		if(as.integer(strftime(res$fecha[1], format = "%M")) == 0) break
		res <- res[-1,]
	}
	res <- res[-1,] # Se elimina una fila más ya que este dato pertenece a la medida anterior
	print(paste("Se eliminan las", filasRes - nrow(res), "primeras filas."))
	return(res)
}

## buscaUltimor00 se usa en los cálculos de los datos horarios, para eliminar los registros que pueda haber al final de la df.datosEnfermedades que no sean de las xx:00
buscaUltimo00 <- function(res){
	filasRes = nrow(res)
	repeat{
		if(nrow(res) == 0) break
		if(as.integer(strftime(res$fecha[nrow(res)], format = "%M")) == 0) break
		res <- res[-nrow(res),]
	}
	print(paste("Se eliminan las", filasRes - nrow(res), "ultimas filas."))
	return(res)
}

# Proceso qeu para una ID y unas fechas genera una dt con los datos mínimos para ejecutar cálculos de enfermedades: temperaturas, humedadesRelativas, humectaciones, pluviometrías
get_CESENS_DatosEnfermedades <- function(IDUbicacion, fechaInicio, fechaFin = NA, horarios = TRUE, unidadesMetricaHumectacion = "porcentaje") #!!! Da por hecho que existe el objeto tokenCESENS en memoria
{
	metricaTemperatura = 1
	metricaHR = 6
	if(unidadesMetricaHumectacion == 'porcentaje')
	{
		metricaHumectacion = 2 # porcentaje
	}else
	{
		metricaHumectacion = 26 # tiempo de humectación
	}
	metricaLluvia = 11 # Lluvia

	#print(paste("Calculado desde: ", fechaInicio, "hasta fecha fin:", fechaFin))
	datosTemp <- get_df.Datos_CESENS(IDUbicacion, metricaTemperatura, fechaInicio, fechaFin)
	datosHR <- get_df.Datos_CESENS(IDUbicacion, metricaHR, fechaInicio, fechaFin)
	datosHumectacion <- get_df.Datos_CESENS(IDUbicacion, metricaHumectacion, fechaInicio, fechaFin)
	datosLluvia <- get_df.Datos_CESENS(IDUbicacion, metricaLluvia, fechaInicio, fechaFin)

	if(!is.na(datosTemp$fecha) && !is.na(datosHR$fecha))
	{
		res <- merge(datosTemp, datosHR, by = "fecha")
	# }else
	# {
		#!!! OJO QUE AQUÍ DEBERÍA HABER ALGO
	# }

		if(!is.na(datosHumectacion$fecha))
		{
			res <- merge(res, datosHumectacion, by = "fecha")
		}else
		{
			res$PHumectacion = NA
		}
		if(!is.na(datosLluvia$fecha))
		{
			res <- merge(res, datosLluvia, by = "fecha")
		}else
		{
			res$Lluvia = 0#NA
		}

		names(res) <- c("fecha", "TAirMd", "HRAirMd", "PHumectacion", "Lluvia")

		if(horarios != TRUE)
		{# Devolver los datos tal como vienen de CESENS
			res <- list(success = TRUE, datos = data.frame(fecha = fecha, TAirMd = temperatura, HRAirMd = HR, THumectacion = humectacion, PAcum = Lluvia))
		}else
		{# Devolver los datos en formato horario
			res <- buscaPrimer00(res)
			res <- buscaUltimo00(res)

			res$fecha <- res$fecha - 1
			ends <- endpoints(res$fecha, 'hours', 1)
			res$fecha <- res$fecha + 1
			fecha <- res$fecha[ends]
			temperatura <- period.apply(res$TAirMd, INDEX = ends, FUN = mean)
			HR <- period.apply(res$HR, INDEX = ends, FUN = mean)
			Lluvia <- period.apply(res$Lluvia, INDEX = ends, FUN = sum)
			if(unidadesMetricaHumectacion == 'porcentaje')
			{
				calculaHumectacion <- function(fecha, ends, vectorHumectaciones, porcentajeHumectacionUmbral = 10)
				{
					dataSamplingTime = difftime(last(fecha), first(fecha), units = "minutes")/length(fecha)
					res <- ifelse(vectorHumectaciones > porcentajeHumectacionUmbral, dataSamplingTime, 0)
                    return(res)
				}

				if(any(!is.na(res$PHumectacion)))
			    {
				    humectacion <- calculaHumectacion(res$fecha, ends, res$PHumectacion) #, porcentajeHumectacionUmbral = 10){
			    }else
			    {
				    humectacion <- 0
    			}
            humectacion <- calculaHumectacion(res$fecha, endpoints, res$PHumectacion)
			}else
			{
				humectacion <- period.apply(res$THumectacion, INDEX = ends, FUN = sum)
			}

			res <-  list(success = TRUE,
                            data.frame(fecha = fecha, TAirMd = temperatura, HRAirMd = HR, THumectacion = humectacion, PAcum = Lluvia))
		}
	}else{
		print("Error, alguno de los datos devueltos es NA")
		res <- list(success = FALSE,
                     data.frame(fecha = NA, TAirMd = NA, HRAirMd = NA, THumectacion= NA, PAcum = NA))
	}

	return(res)
}


#!/usr/bin/env Rscript

################################################
################################################
## REQUIREMENTS                               ##
################################################
################################################

## DIFFERENTIAL TRANSCRIPT EXPRESSION ANALYSIS
    ## - TRANSCRIPT COUNT QUANTIFICATION INPUTS FROM EITHER STRINGTIE2+FEATURECOUNTS OR BAMBU
    ## - SAMPLE INFORMATION INCLUDING CONDITIONS

################################################
################################################
## LOAD LIBRARIES                             ##
################################################
################################################

library(DRIMSeq)
library(DEXSeq)
library(stageR)

################################################
################################################
## PARSE COMMAND-LINE PARAMETERS              ##
################################################
################################################

args = commandArgs(trailingOnly=TRUE)
if (length(args) < 2) {
    stop("Please input the directory with the transcript level featureCounts results and the sample information file", call.=FALSE)
}
transcriptquant <- args[1]
path            <- args[2]

###################################################
###################################################
## FORMAT TRANSCRIPT COUNT QUANTIFICATION OUTPUT ##
###################################################
###################################################

if (transcriptquant == "stringtie2"){
    count.matrix     <- data.frame(read.table(path,sep="\t",header=TRUE, skip = 1))
    count.matrix$Chr <- count.matrix$Start <- count.matrix$End <- count.matrix$Length <- count.matrix$Strand <- NULL
    colnames(count.matrix)[2:length(colnames(count.matrix))] <- unlist(lapply(strsplit(colnames(count.matrix)[2:length(colnames(count.matrix))],"\\."),"[[",1))
}

if (transcriptquant == "bambu"){
    count.matrix           <- data.frame(read.table(path,sep="\t",header=T))
    colnames(count.matrix) <- unlist(lapply(strsplit(colnames(count.matrix),"\\."),"[[",1))
}
colnames(count.matrix)[1] <- "feature_id"
colnames(count.matrix)[2] <- "gene_id"

################################################
################################################
## READ IN SAMPLE INFORMATION (CONDITIONS)    ##
################################################
################################################
sample_id <- colnames(count.matrix[,3:length(count.matrix)])
condition <- sub("(^[^-]+)_.*", "\\1", sample_id)
sampleinfo<-data.frame(sample_id, condition)
condition_names         <- sampleinfo[!duplicated(sampleinfo$condition),]$condition
lgcolName               <- "log2fold"
for (i in length(condition_names):1){
    lgcolName <- paste(lgcolName,condition_names[i],sep='_')
}

################################################
################################################
## FILTERING                                  ##
################################################
################################################

cat(paste(sampleinfo$sample_id, collapse = " "))
cat(paste(colnames(count.matrix), collapse = " "))
d <- dmDSdata(counts=count.matrix, samples=sampleinfo)
# include genes expressed in minimal min_samps_gene_expr samples with min_gene_expr
# include transcripts expressed in min_samps_feature_expr samples with min_feature_expr;
# include transcripts expressed in min_samps_feature_prop samples with min_feature_prop;
n_samp_gene <- length(sampleinfo$sample_id)/2
n_samp_feature <- length(sampleinfo$sample_id)/2
min_count_gene <- 5
min_count_feature <- 5
dFilter <- dmFilter(d,
                    min_samps_feature_expr = n_samp_feature,
                    min_samps_feature_prop = n_samp_feature,
                    min_samps_gene_expr = n_samp_gene,
                    min_feature_expr = min_count_feature,
                    min_gene_expr = min_count_gene,
                    min_feature_prop=0.1)

################################################
################################################
## RUN DEXSEQ                                 ##
################################################
################################################

formulaFullModel <- as.formula("~sample + exon + condition:exon")
dxd <- DEXSeqDataSet(countData=round(as.matrix(counts(dFilter)[,-c(1:2)])),
                    sampleData=DRIMSeq::samples(dFilter),
                    design=formulaFullModel,
                    featureID = counts(dFilter)$feature_id,
                    groupID=counts(dFilter)$gene_id)

dxd <- estimateSizeFactors(dxd)
print('Size factor estimated')
dxd <- estimateDispersions(dxd, formula = formulaFullModel)
print('Dispersion estimated')
dxd <- testForDEU(dxd, fullModel = formulaFullModel)
print('DEU tested')
dxd <- estimateExonFoldChanges(dxd)
print('Exon fold changes estimated')

# Extract DEXSeq results
dxr <- DEXSeqResults(dxd, independentFiltering=FALSE)

### Pinpoint genes with transcripts differentially used ###
##### and transcripts that are differentially used ########
strp <- function(x) substr(x,1,15)
qval <- perGeneQValue(dxr)
dxr.g <- data.frame(gene=names(qval),qval)

columns <- c("featureID","groupID","pvalue",lgcolName)
dxr_pval <- as.data.frame(dxr[,columns])
#head(dxr_pval)
pConfirmation <- matrix(dxr_pval$pvalue,ncol=1)
dimnames(pConfirmation) <- list(strp(dxr_pval$featureID),"transcript")
pScreen <- qval
names(pScreen) <- strp(names(pScreen))
tx2gene <- as.data.frame(dxr_pval[,c("featureID", "groupID")])
for (i in 1:2) tx2gene[,i] <- strp(tx2gene[,i])

stageRObj <- stageRTx(pScreen=pScreen, pConfirmation=pConfirmation,
                    pScreenAdjusted=TRUE, tx2gene=tx2gene)
stageRObj <- stageWiseAdjustment(stageRObj, method="dtu", alpha=0.05)
suppressWarnings({
    dex.padj <- getAdjustedPValues(stageRObj, order=FALSE,
                                onlySignificantGenes=FALSE)
})
write.csv(cbind(dxr_pval,dex.padj$gene,dex.padj$transcript), file="dexseq.results.txt")