#########################################
# Simulation of Data
#########################################
# Must be recurrent: each var can depend
# only on the previously listed vars.
#
# Use 'nsamps' to specify the size of inputs

# B causes A
B.to.A = list(
  vars = list(B=NULL, A=NULL),
  eqn = c(
    'rnorm(nsamps)',
    'B + rnorm(nsamps)')
);
class(B.to.A) = 'cnet';

# C causes both A and B
cnet.common.cause = list(
  vars = list(C=NULL, B=NULL,A=NULL),
  eqn = c(
    'rnorm(nsamps)',
    'rnorm(nsamps)+C',
    'rnorm(nsamps)-C')
);
class(cnet.common.cause) = 'cnet';

# C causes both A and B
cnet.witness = list(
  vars = list(A=NULL, B=NULL, C=NULL),
  eqn = c(
    'rnorm(nsamps)',
    'rnorm(nsamps)',
    'rnorm(nsamps) - A + B')
);
class(cnet.witness) = 'cnet';

# Mediator --- A <- C <- B
cnet.mediator= list(
  vars = list(B=NULL, C=NULL, A=NULL),
  eqn = c(
    'rnorm(nsamps)',
    'B + rnorm(nsamps)',
    'rnorm(nsamps) - C')
);
class(cnet.mediator) = 'cnet';

`A<-C->B` <- cnet.common.cause
`A->C<-B` <- cnet.witness
`A<-C<-B` <- cnet.mediator
cnet.chain <- cnet.mediator # For backward compatibility.  Deprecate this.

jock = list(
  vars = list( IQ=NULL, Athletic=NULL, College=NULL, Varsity=NULL),
  eqn = c(
     'rnorm(nsamps,mean=100,sd=15)',
     'rnorm(nsamps,mean=20,sd=3)',
     'boolean.to.factor((IQ + 3*Athletic + rnorm(nsamps,mean=0,sd=5))>170)',
     "boolean.to.factor(College=='Yes' & (Athletic+rnorm(nsamps,sd=2)  > 25))")
);
class(jock) = 'cnet';

campaign.spending = list(
    vars = list( popularity=NULL, polls=NULL, spending=NULL, vote=NULL ),
    eqn = c(
        "runif(nsamps, min=15,max=85)",
        "popularity + rnorm(nsamps,sd=3)",
        "100 - polls + rnorm(nsamps,sd=10)",
        "0.75*popularity + 0.25*spending + rnorm(nsamps,sd=5)" )
);
class(campaign.spending) = 'cnet';

university.test = list(
 vars = list(stdev=10, student=NULL, when=NULL, university=NULL, score=NULL),
 hidden=c(1),
 eqn = c(
  "1",
  "factor(paste('sID',rep( round(runif(nsamps*5,min=10000000,max=20000000)), each=2),sep=''))",
   "as.factor(c('entrance','graduation')[1+ (1:length(student))%%2])",
   "as.factor(c('UnivA','UnivB','UnivC','UnivD','UnivE')[1+as.numeric(student)%%5])",
   "round(c(0,20,40,60,100)[as.numeric(university)]*as.numeric(when=='graduation') + c(500,490,480,480,470)[as.numeric(university)] + rnorm(length(student),mean=0,sd=stdev))"
    )
);
class(university.test) = 'cnet';

electro = list(
    hidden=c(3), # don't return the underlying rate
    vars = list( animal=NULL, genotype=NULL, rate=NULL, interval=NULL),
    eqn = c(
      "rep(1:10,each=nsamps)",
      "c('Wild-type','Mutant')[1+animal%%2]",
      "rep(runif(1, .25, .75),each=nsamps) + .1*(animal%%2)",
      "rexp( 10*nsamps, rate=rate )")
);
class(electro) = 'cnet';

heights = list(
    vars = list( mgenes=NULL, fgenes=NULL, kgenes=NULL,
                Sex=NULL,
                MHeight=NULL,FHeight=NULL,KHeight=NULL),
    eqn = c(
       "rnorm(nsamps, mean=0,sd=2)",
       "rnorm(nsamps, mean=0,sd=2)",
       ".5*mgenes + .5*fgenes",
       "sample(c('F','M'),nsamps,replace=TRUE)",
       "mgenes + rnorm(nsamps,mean=69,sd=2.5)",
       "fgenes + rnorm(nsamps,mean=65,sd=2.5)",
       "kgenes + rnorm(nsamps,mean=69,sd=2.5) - 4*(Sex=='F')"  )
);
class(heights) = 'cnet';

cnet.unconnected.causes = list(
   vars = list( C = NULL, B = NULL, A = NULL),
   eqn = c(
        "rnorm( nsamps )",
        "rnorm( nsamps )",
        "B + C + rnorm(nsamps,sd=.1)")
);
class(cnet.unconnected.causes) = 'cnet';

cnet.connected.causes = list(
   vars = list( C = NULL, B = NULL, A = NULL),
   eqn = c(
        "rnorm( nsamps )",
        "C + rnorm( nsamps,sd=.1 )",
        "B + C + rnorm(nsamps,sd=.1)")
);
class(cnet.connected.causes) = 'cnet';

cnet.correlated.causes = list(
   hidden=c(1),  # don't display the first variable
   vars = list( D = NULL, C = NULL, B = NULL, A = NULL),
   eqn = c(
        "rnorm( nsamps )",
        "D+rnorm(nsamps,sd=.1)",
        "D+rnorm(nsamps,sd=.1)",
        "B + C + rnorm(nsamps,sd=.1)")
);
class(cnet.correlated.causes) = 'cnet';

aspirin = list(
   vars = list( sick=NULL, mgPerDay=NULL, stroke=NULL ),
   eqn = c(
       "sample(c(rep(0,20),1:10,1:3,8:10), nsamps,replace=TRUE)",
       "5*(sick<2)*sample(c(0,0,0,0:10,0:20),nsamps, replace=TRUE) + (sick>=2)*5*sample(c(0,0,0,0:20,10:20,15:20),nsamps,replace=TRUE)",
       "cut(rnorm(nsamps,mean=0,sd=5) + 2*sick - mgPerDay/10, c(-Inf,5,Inf), labels=c('N','Y'))")
);
class(aspirin) = 'cnet';
# ============================
accidentReduction = list(
    vars = list(danger=NULL,effect=0,threshold=0.9,intersection=NULL,before=NULL,zone=NULL,after=NULL),
    hidden=c(1,2,3),
    eqn=c(
      "runif(n,min=1,max=40)",
      0,   # above -100
      0.9, # must be between 0 and 1
      "sample(cross(rep(c('Snelling','Fairview','Cleveland','Hamline','Lexington'),each=n),rep(paste(c('Selby','Fairmont','Jefferson','Hartford','Ford','Marshall','StClair','Grand','Randolph','Ford','Summit'),c('','',LETTERS[1:3]),sep=''),n)),size=n)",
      "rpois(n,lambda=danger)",
      "before > qdata(threshold, before)",
      "rpois(n,lambda=(danger + effect*zone*danger/100))") # effect is a percentage, e.g. -30, +50
);
class(accidentReduction) = 'cnet';

# =======================
salaries = list(
   vars = list( age=NULL, sex=NULL, children=NULL,rank=NULL, salary=NULL ),
   eqn = c(
       "round(runif(nsamps, min=32, max=65) + rnorm(nsamps,sd=4))",
       "cut( (age-50)*(age>50) + rnorm(nsamps,sd=10), c(-Inf,0,Inf),labels=c('F','M') )",
       "sample(c(0,0,0,1,1,1,2,2,3),nsamps,replace=TRUE)",
       "cut( age + 2*(sex=='M') -sample(c(0,1),nsamps,replace=TRUE)*(sex=='F')*children^2  + rnorm(nsamps,sd=3),c(-Inf,38,47,Inf),labels=c('Assist','Assoc','Full'))",
       "20000+500*age + rnorm(nsamps,sd=2000) + 5000*(rank=='Assoc') + 10000*(rank=='Full')")
);
class(salaries) = 'cnet';
# ============================
bogus.groups = list(
  vars = list( ngroups=5, group=NULL, val=NULL),
  hidden=c(1),
  eqn = c(
    "5",
    "rep(LETTERS[1:ngroups[1] ], each=nsamps)",
    "rnorm(ngroups[1]*nsamps, mean=100, sd=15)"
    )
  );
class(bogus.groups) = 'cnet';
# a specialized program for analysis of these bogus-group data
# control sets whether to compare the groups to a control group.
# otherwise
compare.many.groups = function(d, control=NULL){
  compare.two = function(one,two,ind) {
      sset = subset( d, group==one | group==two )
      sset$group = as.factor(as.character(sset$group))
      foo = summary(lm( val ~ group, data=data.frame(sset) ) )
      group1[ind] <<- one
      group2[ind] <<- two
      pvalue[ind] <<- foo$coef[2,4]
      differ[ind] <<- foo$coef[2,1]
      return(TRUE)
    }
  gps = levels(d$group)
  ncomps = ifelse(is.null(control),
    length(gps)*(length(gps)-1)/2,
    length(gps)-1)
  group1 = rep("",ncomps)
  group2 = rep("",ncomps)
  pvalue = rep(0,ncomps)
  differ = rep(0,ncomps)
  ind = 0
  if (is.null(control)) {
    for (j in 1:(length(gps)-1) ) {
      for (k in (j+1):length(gps) ) {
        ind = ind+1
        one = gps[j]
        two = gps[k]
        compare.two( one, two, ind )
      }
    }
  }
  else {
    if( !any(control==gps) )
      stop("Control group not in the data.")
    else {
      for (k in 1:length(gps)) {
        if (gps[k] != control) {
          ind = ind+1
          two = gps[k]
          compare.two( control, two, ind )
        }
      }
    }
  }
  return( data.frame( group1=group1, group2=group2, diff=differ, pvalue=pvalue))
}

##########################################
# Utility functions
names.cnet = function(net){names(net$vars)}

equations = function(net) {
  if (class(net) == 'cnet.hidden') return( 'hidden');
  nm = names( net$vars )
  for (k in 1:length(nm)){
      cat((paste(nm[k], '<==', net$eqn[k],'\n')))
  }
  invisible(net)
}

print.cnet = function(net) {
  foo = influences(net);
  N = names(foo);
  cat(paste('Causal Network with ',length(N),' vars: ',
            paste(N,collapse=', '),
            '\n===============================================\n'))
  for (k in 1:length(N)){
    if (length(foo[[k]])==0) {
      cat((paste(N[k], 'is exogenous\n', collapse=' ')) )}
    else{
      cat((paste(N[k],'<==', paste(foo[[k]],collapse=' & '),'\n')))}
  }
  invisible(net)
}

influences = function(net) {
  foo = net$vars;
  N = names( net$vars )
  for (k in 1:length(net$eqn) ) {
      goo = net$eqn[[k]];
      goo = all.vars(parse(text=goo))
      keep = goo %in% N;
      foo[[k]] = goo[keep]
  }
  return(foo)
}

boolean.to.factor = function(bool, levels=c('No','Yes')){
  res = rep(levels[1], length(bool));
  res[bool] = levels[2];
  return( as.factor(res) )
}

############################################
# For hidden cnets --- class cnetHidden
names.cnetHidden = function(net){names(net$vars)}
print.cnetHidden = function(net){
  cat('The internal structure of this cnet is hidden.\n')
  cat('The variables are:\n')
  cat(names(net) )
  cat('\n')
}

##########################################
# The main function for running things

run.sim = function(net, n=5, inject=FALSE, seed=NULL,...){
  if( !is.null(seed) ) set.seed(seed)
  nsamps = n;

  # Transfer the experimental variables listed in ... to the
  # net structure so that those variables are set.
  L = list(...);
  vnames = names(net$vars);
  enames = names(L)
  # Check for errors in the argument list
  if (length(enames) > 0 ){
  for (k in 1:length(enames)){
    if (! enames[k] %in% vnames ) {
        warning(paste('**', enames[k],"** not a variable in the network. Check spelling."))
    }
  }
  }

  for (k in 1:length(L)) {
    ind = which( enames[k] == vnames);
    if (length(ind) > 0 ) {
       net$vars[[ind]] = L[[k]];
    }
  }

  # Run through the equations to set each variable in turn
  # If the variable is already set (experimentally, with ...)
  # then just leave it at that.
  for( k in 1:length(net$vars) ){
     if (is.null(net$vars[[k]]) | inject ){
        # figure out what the network says it should be naturally
        hoo = eval( parse(text=net$eqn[[k]]), envir=net$vars)
        if (inject & !is.null(net$vars[[k]])) {
            # add the experimental value to the natural value
            # that is, an incremental experiment.
            hoo = hoo + rep(net$vars[[k]], length.out=nsamps);
        }
     }
     else {
        # copy it from the value set in the argument list
          hoo = rep(net$vars[[k]], length.out=nsamps);
     }

    net$vars[[k]] = hoo;
  }

  ret = data.frame(net$vars)

  post = net[['post']]
  if (!is.null(post) ){
    ret = post(ret)
  }

  hidden = net[['hidden']]
  if( !is.null(hidden) ){
    ret = ret[,-hidden]
  }

  return(ret)
}

######################################
# See problem f2008-6 and f2008-5 (of which this is a simulation)

economic.outlook.poll = list(
   vars = list( rawage=NULL, rawincome=NULL, rawpessimism=NULL, age=NULL, income=NULL, pessimism=NULL ),
   hidden = 1:3,
   eqn = c(
       "runif(nsamps,min=18,max=80)",
       "runif(nsamps,min=-4,max=120) - 50*(rawage<30)",
       "120-rawincome + rawage" ,
       "cut(rawage, breaks=c(18,29,39,64,Inf),
         labels=c('[18 to 29]', '[30 to 39]', '[40 to 64]', '[65 and older]'),
         include.lowest=TRUE)",
       "cut(rawincome, breaks=c(-Inf,20,35,50,100,Inf),
         labels=c('[less than $20000]', '[$20,000 to $34,999]',
         '[$35,000 to $49,999]', '[$50,000 to $99,999]', '[$100,000 or more]'),
                  include.lowest=TRUE)",
       "pmin(10,pmax(0,round(rawpessimism/17)))")
     );
class(economic.outlook.poll) = 'cnet';

#########################################
# See problem f2008/Survival/survival-bias.tex
survival = list(
   hidden = c(4,5),
   vars = list( admitted=NULL,survival=NULL,death=NULL,start='12/1/2000',end='12/1/2000',label='NA'),
   eqn = c(
       "as.Date('9/16/1990', '%m/%d/%Y') + runif(nsamps,0,10000)",
       "round( runif(nsamps,0,5) + rexp(nsamps,rate=1/600) )",
       "admitted + survival"),
# include only the ones that fall between the start and end dates
  post = function(d){
    startnum = as.Date(d$start, '%m/%d/%Y')
    endnum = as.Date(d$end, '%m/%d/%Y')
    d = subset(d, d$admitted <= endnum & d$death >= startnum)
    return(d) }
  );
class(survival) = 'cnet';

#################################
# Vitamin D and systolic blood pressure, with race as a covariate.
vitaminD = list(
 vars = list(magic=20, race=NULL, D=NULL, systolic=NULL ),
 hidden=c(1),
 eqn = c(
  "1",
  "resample(c('B','W','W','W'), nsamps)",
  "pmax(0,round(rnorm(nsamps,mean=37.7,sd=10)*(race=='B') + rnorm(nsamps,mean=71.8,sd=20)*(race=='W')))",
  "pmax(80,round(130 + rnorm(nsamps, mean=0, sd=8) + rexp(nsamps,rate=.15) + magic*(30-D)/200))"
    )
);
class(vitaminD) = 'cnet';

# vitamin D values for Blacks and whites are from Kevin McKinney et al.,
# Association of Race, Body Fat and Season with Vitamin D Status Among
# Young Women: A Cross-sectional Study, Clin. Endocrinol. 2008:69(4):535-541
# http://www.medscape.com/viewarticle/584518

# =====================
# Heart rate during standing and sitting.  Delta sets the difference.
fix.hr.experiment = function(L) {
  standL = L;
  standL$posture=rep("standing", nrow(L))
  standL$hr = L$hr + L$delta + rnorm(nrow(L),sd=3) + (L$age - 55)/50
  hoo = rbind(L,standL)
  hoo = hoo[,-1]
  hoo$age = round(floor(hoo$age))
  hoo$hr = round(hoo$hr)
  inds = order( as.character(hoo$subject) )
  hoo = hoo[inds,]
  return(hoo)
}

hr.experiment = list(
     vars = list(delta=2, age=NULL, subject=NULL, posture=NULL, hr=NULL),
     eqn = c(
       "'set by command: default 2'",
       "runif(nsamps,min=18,max=90)",
       "paste('Subj', 1050 + (1:nsamps), sep='')",
       "rep('sitting',nsamps )",
       "c(70 + rnorm(nsamps,sd=5))"
       ),
      post = fix.hr.experiment
  );
class(hr.experiment) = "cnet";

#################################
# Library book simulatio
#######################
select.books = function(howmany=25,nshelves=4){
  ylim = c(0,nshelves)
  xmax = 20
  bookmax = 80
  books = list()
  heights = list()
  colors = c(terrain.colors(20),topo.colors(20),heat.colors(20))
  draw.a.book = function(k,j,color=NULL,border="gray") {
      h = heights[[k]][j]
      left = books[[k]][j]
      right = books[[k]][j+1]
      if( is.null(color) ) color = colors[ceiling(runif(1,0,length(colors)))]
      polygon( c(left,right,right,left,left), k-1+c(.02,.02, h, h, .02) ,
              col=color,border=border)
  }
  for (k in 1:nshelves) {
    books[[k]] = c(0,cumsum(pmin(.6,pmax(.05,rexp(bookmax,rate=5)))))
    heights[[k]] = runif(bookmax,.5, .9)
  }
  plot( 0:20, ylim = c(0,nshelves), xlim=c(0,xmax), type='n', bty='n',xaxt="n", yaxt="n",xlab="",ylab="")
  for (k in 1:nshelves){
    lines( c(0,xmax), c(k,k)-1, col="black", lwd=5)
    for (j in 1:bookmax) {
       draw.a.book(k,j)
    }
  }
  bookwidths = c()
  shelves = c()
  for (k in 1:nshelves) {
    bookwidths = c(bookwidths, diff(books[[k]]))
    shelves = c(shelves, rep(k,bookmax))
  }
  bookwidths = 4*ceiling( 457*bookwidths )
  bookset = data.frame( pages=bookwidths, shelf=shelves)
  selected = rep(0, bookmax*nshelves)
  select.a.book = function() {
    L = locator(1)
    shelf = ceiling( L$y )
    booknum = max( which( L$x > books[[shelf]]) )
    if (booknum < 0) booknum = 1
    if (booknum > bookmax) booknum = bookmax
    draw.a.book(shelf,booknum,color='white',border='white')
    return(c(shelf,booknum))
  }
  nselected = 0;
  while (nselected < howmany ){
    foo =select.a.book()
    selected[(foo[1]-1)*bookmax + foo[2]] = 1
    nselected = sum(selected)
  }
bookset$selected = as.factor(c("No","Yes")[1+selected])
  return(bookset)

}
##############################
# Mutual funds simulation used in 3.51, f2009-p109
# simulation of mutual funds
mutual.funds = function(n=100,mgrowth=1.06,sdgrowth=0.05,nyears=5,new.money=1000,orig.money=10000) {
  name = function(k,prefix='year'){paste(prefix,k,sep='')}
  funds = list( )
  starting = runif(n, 10,50)
  starting = (orig.money/n)*(starting / mean(starting))
  funds[[name(0)]] = starting
  cum.growth = rep(1,n)
  killed = rep(FALSE,n)
  for (k in 1:nyears ) {
    growth = rnorm(n, mean=mgrowth, sd=sdgrowth)
    # cumulative growth up to the point where a fund was killed
    cum.growth = ifelse(killed,cum.growth,cum.growth*growth)
    funds[[name(k)]] = growth*funds[[name(k-1)]]
    # kill off funds with cumulative losses
    increase = cum.growth
    if (k == 1 ) {# decreased in the first year
      kill = which(  increase < 1.00 )
    }
    else {# growing half as fast as the others
      kill = which( increase < (1 + (mgrowth-1)/2)^k )
    }
    # reinvest the money from the killed funds along with the new money
    add.to.funds = new.money +
      ifelse(length(kill)>0, funds[[name(k)]][kill], 0)
    funds[[name(k)]][kill] = 0
    killed[kill] = TRUE
    # put the new funds in those which have grown more than mgrowth
    # in the last year
    growth.funds = which(funds[[name(k)]] > 0 & growth > mgrowth)
    if (is.null(growth.funds)) {
      # if there aren't any, just split them among the surviving funds
      growth.funds = which( funds[[name(k)]] > 0)
      # if there aren't any, put the money in evenly across all
      if( is.null(growth.funds) ) growth.funds = 1:n
    }

    funds[[name(k)]][growth.funds] = funds[[name(k)]][growth.funds] + add.to.funds/length(growth.funds)
  }
  funds[['growth']] = cum.growth
  return(data.frame(funds))
}


source("/scratch/mblab/dabid/netprophet/code_netprophet3.0/code/netprophet1/global.lars.regulators.r")
## TODO: Both seed and # of cv folds (in global.lars.regulators.r) are parameters that should be exposed to the user
seed <- 747
fold <- 10
tdata <- as.matrix(read.table(targetExpressionFile))
rdata <- as.matrix(read.table(regulatorExpressionFile))
allowed <- as.matrix(read.table(allowedMatrixFile))
pert <- as.matrix(read.table(perturbationMatrixFile))
targets <- seq(dim(tdata)[1])
#TODO
if(microarrayFlag == 0) {
	##RNA-Seq Data
	tdata <- log(tdata+1)/log(2)
	rdata <- log(rdata+1)/log(2)
}

## Center data
tdata <- tdata - apply(tdata,1,mean)
rdata <- rdata - apply(rdata,1,mean)

## Scale data
t.sd <- apply(tdata,1,sd)
t.sdfloor <- mean(t.sd) + sd(t.sd)
t.norm <- apply(rbind(rep(t.sdfloor,times=length(t.sd)),t.sd),2,max) / sqrt(dim(tdata)[2])
tdata <- tdata / ( t.norm * sqrt(dim(tdata)[2]-1) )
#
r.sd <- apply(rdata,1,sd)
r.sdfloor <- mean(r.sd) + sd(r.sd)
r.norm <- apply(rbind(rep(r.sdfloor,times=length(r.sd)),r.sd),2,max) / sqrt(dim(rdata)[2])
rdata <- rdata / ( r.norm * sqrt(dim(rdata)[2]-1) )

## Compute unweighted solution
prior <- matrix(1,ncol=dim(tdata)[1] ,nrow=dim(rdata)[1] )

set.seed(seed)

all.folds <- cv.folds(dim(tdata)[2], fold)


# Stratiifaction analysis of acute outcomes

#first load libraries
library(lme4)
library(lmerTest)
library(emmeans)

pacutes = read.csv("[PATH TO FILE]/pacutes.csv")

# to reproduce the stratification analysis, define the same model as before (acute_analysis.r)
# and add the guess + guess*condition terms (the PANAS is shown in example but works the same for all other outcomes)
m = lmer(formula = value ~ (1|trial_id) + condition + guess + guess*condition + expectation + psychiatric_past, data=subset(pacutes, test_name=='PANAS'))

# then, define the estimated marginal means to compare the 4 strata
emm_fix_guess = emmeans(m, specs = pairwise ~ condition|guess) # stratas with fixed guess
emm_fx_cond   = emmeans(m, specs = pairwise ~ guess|condition) # stratas with fixed condition

emm_fix_guess$contrasts # Comparison of strata with fixed guess (i.e. the two comparisons in the top row of fig5 - PL/PL vs MD/PL and PL/MD vs MD/MD)
emm_fix_cond$contrasts  # Comparison of strata with fixed condition (i.e. the bottom two comparisons on fig 5 - PL/PL vs PL/MD and MD/PL vs MD/MD)


'
Создать функцию, которая по переданному параметру возвращает
наименование дня недели на русском языке.
Если переданное число больше 7, делить на 7 и определять день недели по остатку от деления.
Если число меньше 1, функция возвращает пробел.
Если число действительное, округлять до целого.
'
#Функция
calc <- function(number) {
  #Округление
  number <- round(number, 0)

  #Если больше - берем остаток
  if (number > 7) {
    number <- number %% 7
  }
  #Если меньше 1 - пробел
  if (number < 1) {
    return(" ")
  }

  day <- switch (
    number,
    "Понедельник",
    "Вторник",
    "Среда",
    "Четверг",
    "Пятница",
    "Суббота",
    "Воскресенье"
  )
  return(day)
}

#Основная программа
{
  #Запускаем функцию нормально
  result <- calc(20)
  print(result)
}


##Reproduction of Figure 3 Manuscript

rm(list=ls())
library(reshape2)
library(viridis)
library(ggplot2)

#example for HC - J genes in Canzar dataset (you can change for any gene type)

matrix <- read.table("Canzar/HC_J.txt")
matrix <- as.matrix(matrix)
melted_cormat <- melt(matrix)
melted_cormat$Var1 <- factor(melted_cormat$Var1, levels=c("VDJpuzzle","MIXCR","TRUST4","BRACER","BALDR","BASIC"))
melted_cormat$Var2 <- factor(melted_cormat$Var2, levels=c("VDJpuzzle","MIXCR","TRUST4","BRACER","BALDR","BASIC"))

# Get lower triangle of the correlation matrix
get_lower_tri<-function(matrix){
  matrix[upper.tri(matrix)] <- NA
  return(matrix)
}

lower_tri <- get_lower_tri(matrix)
lower_tri

# Melt the correlation matrix
library(reshape2)
melted_cormat <- melt(lower_tri, na.rm = TRUE)
head(melted_cormat)
melted_cormat$Var1 <- factor(melted_cormat$Var1, levels=c("VDJpuzzle","MIXCR","TRUST4","BRACER","BALDR","BASIC"))
melted_cormat$Var2 <- factor(melted_cormat$Var2, levels=c("VDJpuzzle","MIXCR","TRUST4","BRACER","BALDR","BASIC"))

# Heatmap
library(ggplot2)

# Create a ggheatmap
ggheatmap <- ggplot(melted_cormat, aes(Var2, Var1, fill = value))+
  geom_tile(color = "white")+
  scale_fill_viridis(discrete=FALSE)+
  theme_minimal()+ # minimal theme
  theme(axis.text.x = element_text(angle = 45, vjust = 1,
                                   size = 12, hjust = 1))+
  coord_fixed()

# Print the heatmap
print(ggheatmap)

ggheatmap +
  geom_text(aes(Var2, Var1, label = value), color = "black", size = 4) +
  theme(
    axis.title.x = element_blank(),
    axis.title.y = element_blank(),
    panel.grid.major = element_blank(),
    panel.border = element_blank(),
    panel.background = element_blank(),
    axis.ticks = element_blank())+
   guides(fill = guide_colorbar(barwidth = 7, barheight = ,
                               title.position = "top", title.hjust = 0.5))+ theme(plot.title = element_text(size=10))+ theme(text=element_text(size=10))+theme(axis.text.x = element_text(face="bold", color="#000001")) + theme(axis.text.y = element_text(face="bold", color="#000001"))+theme(text = element_text(size = 14, face="bold"))+theme(axis.title.y = element_text(size = 14))+theme(legend.text = element_text(size = 14,face="plain"))+theme(legend.title = element_text(size = 14))+scale_y_discrete(position = "right")


packages <- c("vegan", "ggplot2", "dplyr", "tidyr")
if (length(setdiff(packages, rownames(installed.packages()))) > 0) {
  install.packages(setdiff(packages, rownames(installed.packages())))
}

library(vegan)
library(ggplot2)
library(dplyr)
library(tidyr)

#data filtering:
setwd("/Users/kai/Desktop/software/tax-e/data/freqs") #//set the working directory here:

#####################################################################
# log transformed data
combined <- as.data.frame(read.csv(file = "d1_subsample_log_all.csv",header = TRUE))
combined <- combined %>% select(-sample)
targets <- combined %>% select(target)
combined <- combined %>% select(-target)
combined <- cbind(targets,combined)

# pcoa on d1_subsample_log_all.csv
# doing pcoa on my data
my.dis <- vegdist(decostand(combined[,-1],"hellinger"))
my.pcoa <- cmdscale(my.dis, eig = TRUE)

with(combined, levels(target))
colors_vec <-palette(rainbow(8))
#try to fix it from here https://www.fromthebottomoftheheap.net/2012/04/11/customising-vegans-ordination-plots/
#get the species names
my.pcoa$species <- wascores(my.pcoa$points, combined[,-1], expand = TRUE)

#plot the figure
fig <- ordiplot(my.pcoa, type = "none")
#text(fig, "species", col="#d43e24", cex=0.9)
points(fig, "sites", col=colors_vec,  cex=1, pch=19)
#legend('topright', legend=unique(colors_vec), col=unique(my.pcoa$points), pch = 16)

######################################################################
# workflow for hclust, kmeans and heatmap using
# example tissue gene expession data
# from https://genomicsclass.github.io/book/pages/clustering_and_heatmaps.html

# source("https://bioconductor.org/biocLite.R")
# biocLite("tissuesGeneExpression")
# biocLite("remotes")
# library(BiocInstaller)
# biocLite("genomicsclass/tissuesGeneExpression")
# library(tissuesGeneExpression)
# data(tissuesGeneExpression)

#hierarchical clustering
#install.packages("devtools")
library(devtools) # get from CRAN with install.packages("devtools")
install_github("ririzarr/rafalib")
library(rafalib)

#########################
# in my example targets is equivalent to tissue and combined to e.
#compute the distance between each sample:
d_data <- dist(as.matrix(combined))   # find distance matrix
hc_data <- hclust(d_data, method = "ward.D2")       # apply hirarchical clustering
targets_chr <- sapply(targets, unlist)

mypar(1,1)
myplclust(hc_data, labels=targets_chr, lab.col=as.fumeric(targets_chr), cex=0.5)

# cut the tree to look at the individual clusters
hclusters <- cutree(hc_data, h=110)
table(true=targets_chr, cluster=hclusters)

#We can also ask cutree to give us back a given number of clusters. The function then automatically finds the height that results in the requested number of clusters:

hclusters <- cutree(hc_data, k=6)
table(true=targets_chr, cluster=hclusters)

####
# tf (term freq) data
combined_tf <- as.data.frame(read.csv(file = "d1_subsample_tf_all.csv",header = TRUE))
combined_tf <- combined_tf %>% select(-sample)
targets <- combined_tf %>% select(target)
combined_tf <- combined_tf %>% select(-target)
combined_tf <- cbind(targets,combined_tf)

#compute the distance between each sample:
d_data <- dist(as.matrix(combined_tf))   # find distance matrix
hc_data <- hclust(d_data, method = "ward.D")       # apply hirarchical clustering
targets_chr <- sapply(targets, unlist)

mypar(1,1)
myplclust(hc_data, labels=targets_chr, lab.col=as.fumeric(targets_chr), cex=0.5)

# Heatmap
setwd("/Users/kai/Desktop/software/tax-e/scripts/r_scripts")

library(RColorBrewer)
hmcol <- colorRampPalette(brewer.pal(9, "GnBu"))(100)

#source("https://bioconductor.org/biocLite.R")
#biocLite("genefilter")

#install.packages(genefilter)
library(genefilter)
#install.packages("gplots")
library(gplots) ##Available from CRAN

#rv <- rowVars(e)
#idx <- order(-rv)[1:40]

combined <- as.data.frame(read.csv(file = "d1_subsample_log_all_trans.csv",header = TRUE,row.names = 1))
c <- as.matrix(combined)

rv_data <- rowVars(c)
idx_data <- order(-rv_data )[1:60]

cols <- palette(brewer.pal(8, "Dark2"))[as.fumeric(targets_chr)]
head(cbind(colnames(c),cols))

hclust.ward <- function(c) hclust(c, method="ward.D2")

full <- heatmap.2(c[idx_data,], labCol=targets_chr,
                  trace="none", ColSideColors=cols,
                  col=hmcol, hclustfun=hclust.ward )

row_dend <- cut(full[["rowDendrogram"]], h = 0)
row_dend$lower

col_dend <- cut(full[["colDendrogram"]], h= 100)
col_dend$lower

#####
# tf heatmap
combined <- as.data.frame(read.csv(file = "d1_subsample_tf_all_trans.csv",header = TRUE,row.names = 1))
c <- as.matrix(combined)

rv_data <- rowVars(c)
idx_data <- order(-rv_data )[1:60]
#install.packages("gplots")
#library(gplots) ##Available from CRAN

cols <- palette(brewer.pal(8, "Dark2"))[as.fumeric(targets_chr)]
head(cbind(colnames(c),cols))

hclust.ward <- function(c) hclust(c, method="ward.D2")

full_tf <- heatmap.2(c[idx_data,], labCol=targets_chr,
                  trace="none", ColSideColors=cols,
                  col=hmcol, hclustfun=hclust.ward )


#testing and showing variations on array

# only if you install a Bioconductor package for the first time
# source("http://www.bioconductor.org/biocLite.R")
# # else
# library("BiocInstaller")
# biocLite("PAA", dependencies=TRUE)

 #library(PAA)

library(ARPPA) #this is the my own package to run analysis

#now start reading the text exported data
#this is the batch done on 10/08/2015
datapath<-system.file("extdata", package="ARPPA")
targets <- list.files(system.file("extdata", package="ARPPA"),
	 pattern = "targets_text_Batch1", full.names=TRUE)
elist2<-importTextData(dataFilePath=datapath, targetFile=targets, start.data=51, nrows.data=18803-53,
			start.control=18803, nrows.control=23286,aggregation="geoMean",
			as.is=TRUE, header=TRUE,sep="\t",na.strings="", quote="")
elist2$array.type<-"ProtoArray"
#===>background correction
library(limma)

elist2 <- backgroundCorrect(elist2, method="normexp",
 normexp.method="saddle")

 #now we need to rearrange the control and testing proteins to background correct control
 #it works this way that background correction only working on elist$E
 #so we have to do the rearrangement
 elist_c<-elist2
 elist_c$E<-elist2$C
 elist_c$Eb<-elist2$Cb
 #this is good enough, we don't have to change elistC$C, since other fields are not touched
 elist_c<-backgroundCorrect(elist_c, method="normexp",
 normexp.method="saddle")

 #now change it back
 elist2$C<-elist_c$E
 elist2$Cb<-elist_c$Eb
 ##=====>end of background correction

 indices<-grep("HumanIgG", elist2$cgenes$Name)
 elist2$cgenes[indices,]

###calling the PAA to do the normalization
library(PAA)

elist_norm<-normalizeArrays(elist=elist2, method="rlm",
  cyclicloess.method="fast", control ="HumanIgG")

 #now we have everything, we just need to summarize the data
 #into "residue" over the sliding window over protein amount

 MFI<-elist_norm$E[,1]  #for control now
 proteinAmt<-elist_norm$genes[,"Protein.Amount"]

 #now we need to summarize the data to get "residue"
 #in this case, we don't run regression fitting yet,
 #so we only define a sliding window aross protein amount
 #and then average the windowed MFI and get the "residua"
 #first
 winSize<-50
 maxAmt<-max(proteinAmt)
 numBins<-ceiling(maxAmt/winSize)
 MFI_res<-MFI
 for(i in 1:numBins)
 {
	aveMFI<-ave(MFI[proteinAmt>=(i-1)*winSize&proteinAmt<i*winSize])
	MFI_res[proteinAmt>=(i-1)*winSize&proteinAmt<i*winSize]<-MFI[proteinAmt>=(i-1)*winSize&proteinAmt<i*winSize]-aveMFI

 }

 #mdl<-lm(MFI~Gene*Sample)#, dtFrame)
 plot(proteinAmt, MFI_res)
 reslm<-lm(MFI_res~proteinAmt)
 abline(reslm,col=2, lwd=2)


# ver 2.0 -- marc, 11, 2020
# naiv, egyerszeru modell a magyar COVID-19 fertozott betegek szamanak rovidtavu alakulasara

# a modell azért naiv, mert NEM veszi figyelembe
#   kezdo gocpontok es azok tavolsaganak hatasak
#   a mar valamennyire tisztazott parametereket: onset delay, incubation period (5-8nap), reprodukcios szam (2,5), overdispersion stb.
#   orszagok egymasra hatasat, infrastrukturalis valtozokat es a beavatkozasok hatasat
#   SIR modell korlatait. stb.
#   valamint determinisztikus.

#memoria uritese
rm(list = ls())

# parameterek
min_fert <- 19 #honnantol veszi figyelembe az adatsort
min_hossz <- 4 #milyen hosszo adatsort tekint elemezhetonek min
shossz <- 21  # hany napra vetitse elore az eredmenyeket a modell

#BETOLTES
#adatok betoltese Johns Hopkins egyetem folyamatos frissitesu online adataibol
rawcovid <- read.csv("https://raw.githubusercontent.com/CSSEGISandData/COVID-19/master/csse_covid_19_data/csse_covid_19_time_series/time_series_19-covid-Confirmed.csv", header=TRUE, as.is=T, sep=",", fileEncoding = "UTF-8")

#OECD orszagok alapadatai
oecdraw <- read.csv("https://raw.githubusercontent.com/bricoler/naiv_COVID19_HU/R_code/OECD_2019.csv", header=TRUE, as.is=T, sep=",", fileEncoding = "UTF-8")

#AGGREGALAS
#aggregalas orszagokra
#E: itt eldobjuk a GEO-t, de a jovoben lehetne kezdeni valamit a tavolsagi adatokkal, ketdimenzioban (ido, ter)
l2 <- dim(rawcovid)[2] # napok hossza

rcovid <- aggregate(rawcovid[5:l2], by = list(rawcovid$Country.Region), FUN = sum) # orszagok szerinti aggregalas rcovid
rownames(rcovid) <- rcovid[,1] #sornevek javitasa rcovidban
colnames(rcovid)[1] <- "cname"

rownames(oecdraw) <- oecdraw[,1] #sornevek oecdrawban is

# OECD orszagok vizsgalata csak

rrcovid <- rcovid[(rcovid$cname %in% oecdraw$cname),] ##rrcovid: csak OECD orszagok
rrcovid <- rrcovid[,-1] # elso oszlop a cname torlese rrcovidban

#dif matrix eloallitasa (delta elozo nap)
d_covid <- rrcovid[1:dim(rrcovid)[1],2:dim(rrcovid)[2]] - rrcovid[1:dim(rrcovid)[1],(1:(dim(rrcovid)[2]-1))]

#az OECD lakossagszam leosztas
#covid : lakossagszamaranyos fertozottek aranya OECD orszagokban

covid <- rrcovid

for (i in 1:dim(rrcovid)[1])
{
covid[i,] <- rrcovid[i,] / oecdraw[rownames(rrcovid)[i],"pop"]
}

#SZAMITAS
# kulonbozo orszagok metaadatok szamitas, exp es log fuggvenyillesztes
# hianyzik: orszaglakossag es lakossagaranyos emelkedesszamitas

covid[covid==0]<-NA #0-kbol NA

cname <- NULL
chossz <-NULL
cmin <- NULL
cmax <- NULL
cmean <- NULL
cmedian <-NULL
csd <- NULL

tempv <-NULL
tempv2 <- NULL

c_expC <- NULL
c_expbeta <- NULL
c_expR2 <- NULL

c_logC <- NULL
c_logbeta <- NULL
c_logR2 <- NULL

c_tend <- NULL

for (i in 1:dim(covid)[1])
{
cname[i] <- rownames(covid)[i] # orszag neve
cmin[i] <- min(as.numeric(covid[i,]), na.rm=T) * oecdraw[rownames(rrcovid)[i],"pop"] # minimum fertozottszam emberben
cmax[i] <- max(as.numeric(covid[i,]), na.rm=T) * oecdraw[rownames(rrcovid)[i],"pop"] # maximum fertozottszam
cmean[i] <- mean(as.numeric(covid[i,]), na.rm=T) * oecdraw[rownames(rrcovid)[i],"pop"] # atlagos fertozottszam
cmedian[i] <- median(as.numeric(covid[i,]), na.rm=T) * oecdraw[rownames(rrcovid)[i],"pop"] #median fertozottszam
csd[i] <- sd(as.numeric(covid[i,]), na.rm=T) * oecdraw[rownames(rrcovid)[i],"pop"] #sd fertozottszam emberben

tempv <- NULL
tempv2 <- NULL

tempv <- na.omit(as.numeric(covid[i,])) # atmeneti vektor a nullak kidobalasa

tempv2 <- tempv[which( tempv * oecdraw[rownames(rrcovid)[i],"pop"] > min_fert) ] # 17-nel kisebbek kidobalasa - (tempv * vissza kell szorozni lakossagszamra)
chossz[i] <- length(tempv2) # hany nap van tobb mint min_fert fertozott

#ha minhossznak kevesebb a megfigyeles akkor nem szamolunk
#utana exp illesztes
#utana log illesztes

if (length(tempv2)>min_hossz) {
#exp
c_expC[i] <- coef(summary(lm(log(tempv2)~c(1:(length(tempv2))))))[1,1]
c_expbeta[i] <- coef(summary(lm(log(tempv2)~c(1:(length(tempv2))))))[2,1]
c_expR2[i] <- summary(lm(log(tempv2)~c(1:(length(tempv2)))))$adj.r.squared
#log
c_logC[i] <- coef(summary(lm((tempv2)~log(c(1:(length(tempv2)))))))[1,1]
c_logbeta[i] <- coef(summary(lm((tempv2)~log(c(1:(length(tempv2)))))))[2,1]
c_logR2[i] <- summary(lm((tempv2)~log(c(1:(length(tempv2))))))$adj.r.squared

if (c_logR2[i]<c_expR2[i]) {c_tend[i] <- "exp"} else {c_tend[i] <- "log"}

}
else
{
c_expC[i] <- 0
c_expbeta[i] <- 0
c_expR2[i] <- 0
c_logC[i] <- 0
c_logbeta[i] <- 0
c_logR2[i] <- 0
c_tend[i]<- "ned2c" # not enough data to calculate
}

}

cmeta <- data.frame(cname,chossz,cmin,cmax,cmean,cmedian,csd, c_expC, c_expbeta, c_expR2, c_logC, c_logbeta, c_logR2, c_tend)

#cmeta, orszagokrol fertozesmetaadatok

View(cmeta)

#Ahol meg keves adat volt fuggvenyszamitashoz, annak kidobasa

cmeta_exp <- cmeta[as.numeric(which(cmeta$c_tend!="ned2c")),]

#oecd orszagadatok hozzafuzzese a szamitott adatokhoz

cmeta_exp_oecd <- merge(cmeta_exp, oecdraw) # orszagok metadatai exp es log fuggveny es OECD adatok

#tesztek fuggvenyparameterek eloszlasara

shapiro.test(cmeta_exp_oecd$c_expC)[2]
shapiro.test(cmeta_exp_oecd$c_expbeta)[2]
shapiro.test(cmeta_exp_oecd$c_expR2)[2]

shapiro.test(cmeta_exp_oecd$c_logC)[2]
shapiro.test(cmeta_exp_oecd$c_logbeta)[2]
shapiro.test(cmeta_exp_oecd$c_logR2)[2]

#exp_beta
HU_beta <- mean(cmeta_exp_oecd$c_expbeta)
error_beta <- qnorm(0.95)*sd(cmeta_exp_oecd$c_expbeta)/sqrt(dim(cmeta_exp_oecd)[2]-1) # 90% CI

HU_betamax <- HU_beta + error_beta
HU_betamin <- HU_beta - error_beta

#exp_C
HU_C <- mean(cmeta_exp_oecd$c_expC)
error_c <- qnorm(0.95)*sd(cmeta_exp_oecd$c_expC)/sqrt(dim(cmeta_exp_oecd)[2]-1) # 90% CI

HU_Cmax <- HU_C + error_c
HU_Cmin <- HU_C - error_c

#expR2
HU_R2 <- mean(cmeta_exp_oecd$c_expR2)
error_R2 <- qnorm(0.975)*sd(cmeta_exp_oecd$c_expR2)/sqrt(dim(cmeta_exp_oecd)[2]-1)

HU_R2max <- HU_R2 + error_R2
HU_R2min <- HU_R2 - error_R2

# hazai adatok szimulalasa shossz n
pnap <- c(1:shossz)

HU_p <- NULL
HU_pmin <- NULL
HU_pmax <- NULL

# e kitevojeben a josolt beta kiszamitasa

for (i in 1:shossz) {
HU_p[i] <- exp(1)**(HU_C+(HU_beta*i))
HU_pmin[i] <- exp(1)**(HU_Cmin+(HU_betamin*i))
HU_pmax[i] <- exp(1)**(HU_Cmax+(HU_betamax*i))
}

#R2 bizonytalansag fapados hozzaszamitasa
HU_pmin <- (HU_pmin) * HU_R2
HU_pmax <- (HU_pmax) * (1+ (1-HU_R2))

#Kerekites egesz emberre, hazai populacioval felszorzas
HU_pi <- ceiling((HU_p) * oecdraw["Hungary","pop"])
HU_pmini <- ceiling((HU_pmin) * oecdraw["Hungary","pop"])
HU_pmaxi <- ceiling((HU_pmax) * oecdraw["Hungary","pop"])

# eredmenyek dataframe

results <- data.frame(pnap, HU_p, HU_pmin, HU_pmax, HU_pi, HU_pmini, HU_pmaxi)

#vizualizacio
par(mfrow=c(1,1))

#kirajzolas2 : szimulalalt adatok
#hany napot rajzoljon ki : kir

plot(pnap, HU_pmax[1:shossz], xlab = "Napok, X. beteg megjelenése után", ylab = "Igazolt fertőzött betegek aránya, becslés (CI 0.82 - 0.86)", col=8, lty = 2, pch = 16, cex=0)
points (HU_pmin[1:shossz], col =8, pch = 16, cex=0)
polygon(c(pnap[1:shossz], rev(pnap[1:shossz])), c(HU_pmax[1:shossz] ,rev(HU_pmin[1:shossz])), col = rgb(1, 0, 0,0.5) )
points(pnap, HU_p[1:shossz], col=1, lty = 2, pch = 16, cex=1, type="b")

#eredmenyek kiiratasa
View(results)
#technikai reszletek kiirasa
#write.csv(cmeta_exp_oecd, file = "D:/R/Data/covid19_hu_tec_res1.csv", fileEncoding = "UTF-8")
#joslas kiirasa
#write.csv(results, file = "D:/R/Data/covid19_hu_res1.csv",fileEncoding = "UTF-8")

#SIR kod egy resze nem az en szellemi termekem, ezert nem oszthatom meg nyilvanosan, de ha vki ir emailt, kuldom


#' heat_index
#'
#' Calculate the heat index following the NOAA scheme.
#'
#' @param t numeric Air temperature in degC.
#' @param rh numeric Relative humidity in percentage.
#' @return heat index in degC.
#'
#'
#' @author    Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @keywords   NOAA heat index
#' @references NOAA index from George Winterling based on SteadMan's work "The Assessment of Sultriness. Part I: A Temperature-Humidity Index Based on Human Physiology and Clothing Science, R. G. Steadman, Journal of Applied Meteorology, July 1979, Vol 18 No7, pp 861 873.
#' @export
#'
#'

heat_index=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]=heatindex(t[i],rh[i])};")
                         res=ct$get("res")
                         return(ifelse(res==9999,NA,res))
}


file = file("target/123456790.track","rb")
readSingle = function() readBin(file, single(), size=4, endian="big")
readInteger = function() readBin(file, integer(), size=4, endian="big")
readLong = function() {
  a = readBin(file, integer(), size=4, endian="big")
  b = readBin(file, integer(), size=4, endian="big")
  if (a<0)
    stop("haven't handled the negative case but shouldn't happen for 289 million years when reading a unix time in ms so should be safe")
  a*2^32 + b
}
readByte = function() readBin(file, integer(), size=1, endian="big")
readShort = function() readBin(file, integer(), size=2, endian="big")
assertEquals = function(expected, actual)
  if (expected != actual) {
    warning(sprintf("expected %s but was %s", expected, actual))
  }

lat = readSingle()
lon = readSingle()
time = readLong()
latencySeconds=readInteger()
src = readShort()
nav = readByte()
rot = readByte()
sog = readShort()
cog = readShort()
heading = readShort()
cls = readByte()

print(lat)
print(lon)
print(time)
print(latencySeconds)
print(src)
print(nav)
print(rot)
print(sog)
print(cog)
print(heading)
print(cls)

# test returned values
assertEquals(-10, lat)
assertEquals(135, lon)
assertEquals(1421708455237, time)
assertEquals(12, latencySeconds)
assertEquals(1, src)
assertEquals(7, nav)
assertEquals(75, sog)
assertEquals(450, cog)
assertEquals(460, heading)
assertEquals(1, cls)


#' Transformed Cartesian coordinate system
#'
#' `coord_trans()` is different to scale transformations in that it occurs after
#' statistical transformation and will affect the visual appearance of geoms - there is
#' no guarantee that straight lines will continue to be straight.
#'
#' Transformations only work with continuous values: see
#' [scales::trans_new()] for list of transformations, and instructions
#' on how to create your own.
#'
#' @inheritParams coord_cartesian
#' @param x,y Transformers for x and y axes or their names.
#' @param limx,limy **Deprecated**: use `xlim` and `ylim` instead.
#' @export
#' @examples
#' \donttest{
#' # See ?geom_boxplot for other examples
#'
#' # Three ways of doing transformation in ggplot:
#' #  * by transforming the data
#' ggplot(diamonds, aes(log10(carat), log10(price))) +
#'   geom_point()
#' #  * by transforming the scales
#' ggplot(diamonds, aes(carat, price)) +
#'   geom_point() +
#'   scale_x_log10() +
#'   scale_y_log10()
#' #  * by transforming the coordinate system:
#' ggplot(diamonds, aes(carat, price)) +
#'   geom_point() +
#'   coord_trans(x = "log10", y = "log10")
#'
#' # The difference between transforming the scales and
#' # transforming the coordinate system is that scale
#' # transformation occurs BEFORE statistics, and coordinate
#' # transformation afterwards.  Coordinate transformation also
#' # changes the shape of geoms:
#'
#' d <- subset(diamonds, carat > 0.5)
#'
#' ggplot(d, aes(carat, price)) +
#'   geom_point() +
#'   geom_smooth(method = "lm") +
#'   scale_x_log10() +
#'   scale_y_log10()
#'
#' ggplot(d, aes(carat, price)) +
#'   geom_point() +
#'   geom_smooth(method = "lm") +
#'   coord_trans(x = "log10", y = "log10")
#'
#' # Here I used a subset of diamonds so that the smoothed line didn't
#' # drop below zero, which obviously causes problems on the log-transformed
#' # scale
#'
#' # With a combination of scale and coordinate transformation, it's
#' # possible to do back-transformations:
#' ggplot(diamonds, aes(carat, price)) +
#'   geom_point() +
#'   geom_smooth(method = "lm") +
#'   scale_x_log10() +
#'   scale_y_log10() +
#'   coord_trans(x = scales::exp_trans(10), y = scales::exp_trans(10))
#'
#' # cf.
#' ggplot(diamonds, aes(carat, price)) +
#'   geom_point() +
#'   geom_smooth(method = "lm")
#'
#' # Also works with discrete scales
#' df <- data.frame(a = abs(rnorm(26)),letters)
#' plot <- ggplot(df,aes(a,letters)) + geom_point()
#'
#' plot + coord_trans(x = "log10")
#' plot + coord_trans(x = "sqrt")
#' }
coord_trans <- function(x = "identity", y = "identity", xlim = NULL, ylim = NULL,
                        limx = "DEPRECATED", limy = "DEPRECATED", clip = "on", expand = TRUE) {
  if (!missing(limx)) {
    warn("`limx` argument is deprecated; please use `xlim` instead.")
    xlim <- limx
  }
  if (!missing(limy)) {
    warn("`limy` argument is deprecated; please use `ylim` instead.")
    ylim <- limy
  }

  # resolve transformers
  if (is.character(x)) x <- as.trans(x)
  if (is.character(y)) y <- as.trans(y)

  ggproto(NULL, CoordTrans,
    trans = list(x = x, y = y),
    limits = list(x = xlim, y = ylim),
    expand = expand,
    clip = clip
  )
}

#' @rdname ggplot2-ggproto
#' @format NULL
#' @usage NULL
#' @export
CoordTrans <- ggproto("CoordTrans", Coord,
  is_free = function() TRUE,
  distance = function(self, x, y, panel_params) {
    max_dist <- dist_euclidean(panel_params$x.range, panel_params$y.range)
    dist_euclidean(self$trans$x$transform(x), self$trans$y$transform(y)) / max_dist
  },

  backtransform_range = function(self, panel_params) {
    list(
      x = self$trans$x$inverse(panel_params$x.range),
      y = self$trans$y$inverse(panel_params$y.range)
    )
  },

  range = function(self, panel_params) {
    list(
      x = panel_params$x.range,
      y = panel_params$y.range
    )
  },

  transform = function(self, data, panel_params) {
    trans_x <- function(data) transform_value(self$trans$x, data, panel_params$x.range)
    trans_y <- function(data) transform_value(self$trans$y, data, panel_params$y.range)

    new_data <- transform_position(data, trans_x, trans_y)

    warn_new_infinites(data$x, new_data$x, "x")
    warn_new_infinites(data$y, new_data$y, "y")

    transform_position(new_data, squish_infinite, squish_infinite)
  },

  setup_panel_params = function(self, scale_x, scale_y, params = list()) {
    c(
      train_trans(scale_x, self$limits$x, self$trans$x, "x", self$expand),
      train_trans(scale_y, self$limits$y, self$trans$y, "y", self$expand)
    )
  },

  render_bg = function(panel_params, theme) {
    guide_grid(
      theme,
      panel_params$x.minor,
      panel_params$x.major,
      panel_params$y.minor,
      panel_params$y.major
    )
  },

  render_axis_h = function(panel_params, theme) {
    arrange <- panel_params$x.arrange %||% c("secondary", "primary")

    list(
      top = render_axis(panel_params, arrange[1], "x", "top", theme),
      bottom = render_axis(panel_params, arrange[2], "x", "bottom", theme)
    )
  },

  render_axis_v = function(panel_params, theme) {
    arrange <- panel_params$y.arrange %||% c("primary", "secondary")

    list(
      left = render_axis(panel_params, arrange[1], "y", "left", theme),
      right = render_axis(panel_params, arrange[2], "y", "right", theme)
    )
  }
)

transform_value <- function(trans, value, range) {
  if (is.null(value))
    return(value)
  rescale(trans$transform(value), 0:1, range)
}

train_trans <- function(scale, coord_limits, trans, name, expand = TRUE) {
  expansion <- default_expansion(scale, expand = expand)
  scale_trans <- scale$trans %||% identity_trans()
  coord_limits <- coord_limits %||% scale_trans$inverse(c(NA, NA))

  if (scale$is_discrete()) {
    continuous_ranges <- expand_limits_discrete_trans(
      scale$get_limits(),
      expansion,
      coord_limits,
      trans,
      range_continuous = scale$range_c$range
    )
  } else {
    # transform user-specified limits to scale transformed space
    coord_limits <- scale$trans$transform(coord_limits)
    continuous_ranges <- expand_limits_continuous_trans(
      scale$get_limits(),
      expansion,
      coord_limits,
      trans
    )
  }

  # calculate break information
  out <- scale$break_info(continuous_ranges$continuous_range)

  # range in coord space has already been calculated
  # needs to be in increasing order for transform_value() to work
  out$range <- range(continuous_ranges$continuous_range_coord)

  # major and minor values in coordinate data
  out$major_source <- transform_value(trans, out$major_source, out$range)
  out$minor_source <- transform_value(trans, out$minor_source, out$range)
  out$sec.major_source <- transform_value(trans, out$sec.major_source, out$range)
  out$sec.minor_source <- transform_value(trans, out$sec.minor_source, out$range)

  out <- list(
    range = out$range,
    labels = out$labels,
    major = out$major_source,
    minor = out$minor_source,
    sec.labels = out$sec.labels,
    sec.major = out$sec.major_source,
    sec.minor = out$sec.minor_source
  )
  names(out) <- paste(name, names(out), sep = ".")
  out
}

#' Generate warning when finite values are transformed into infinite values
#'
#' @param old_values A vector of pre-transformation values.
#' @param new_values A vector of post-transformation values.
#' @param axis Which axis the values originate from (e.g. x, y).
#' @noRd
warn_new_infinites <- function(old_values, new_values, axis) {
  if (any(is.finite(old_values) & !is.finite(new_values))) {
    warn(glue("Transformation introduced infinite values in {axis}-axis"))
  }
}


#!/usr/bin/env Rscript

# Command line argument processing
args <- commandArgs(trailingOnly=TRUE)

if (!require("ggplot2")){
    install.packages("ggplot2", dependencies=TRUE, repos='http://cloud.r-project.org/')
    library("ggplot2")
}

erccfile <- args[1]
erccref <- args[2]
erccamount <- args[3]

### function ###

SDset <- function(x, y){
  data.frame(x=x, y=y, upper = mean(y)+3*sd(y),lower = mean(y)-3*sd(y))
}

calc_tpm <- function(counts,len) {
  x <- counts/len
    return(t(t(x)*1e6/colSums(x)))
}

### load Ref
ercc_ref = read.table(erccref, sep="\t", comment.char = "", header=T, check.names=FALSE, stringsAsFactors=F)

### calc copy number
ercc_input_amount = eval(parse(text = as.character(erccamount)))
ercc_ref$copy.number = ercc_ref$concentration.in.Mix.1..attomoles.ul. * 10^(-18) * 6.02214086  * 10^23 * ercc_input_amount
ercc_ref$copy.number.log = log10(ercc_ref$copy.number+1)

write.table(ercc_ref,"ercc_dataset_user.txt",sep="\t", append=F, quote=F, row.names=T, col.names=T)

### load countdata
ercc_countdata_tpm_log = read.table(erccfile, sep="\t", comment.char = "", header=T, check.names=FALSE, stringsAsFactors=F)
ercc_ref_sort = ercc_countdata_tpm_log
ercc_ref_sort$ERCC.ID = rownames(ercc_ref_sort)
ercc_ref_sort = dplyr::left_join(ercc_ref_sort, ercc_ref, by=c("ERCC.ID"))

# calc corr
plotdata = cor(ercc_countdata_tpm_log, ercc_ref_sort$copy.number.log)
plotdata = data.frame(corr=plotdata[,1],sample_name=as.character(rownames(plotdata)))
plotdata = plotdata[order(plotdata$sample_name),]
plotdata = SDset(plotdata$sample_name, plotdata$corr)

### draw plot
g = ggplot(plotdata, aes(x=x,y=y)) +
    geom_bar(alpha=0.7, stat="identity") +
    xlab("Sample") + ylab("Corr") +
    ylim(0,1) +
    theme(axis.text.x=element_text(size=6, angle=90, hjust=1), legend.text=element_text(size=8)) +
    ggtitle("ERCC counts and copy number correlation")

ggsave(file = "barplot_ercc_counts_copynum_correlation.pdf", plot=g, dpi=100, width=12, height=5)

# Write correlation values to file
output_data = data.frame(name = plotdata$x, corr=plotdata$y)
rownames(output_data) = output_data$name
write.csv(output_data, 'barplot_ercc_counts_copynum_correlation.csv', quote=FALSE, append=TRUE)

# Printing sessioninfo to standard out
print("Draw ERCC correlation plot info:")
sessionInfo()


# Estat�stica B�sica

# Parte 4 - Tabela de Frequ�ncia

# Definindo a pasta de trabalho
# Substitua o caminho abaixo pela pasta no seu computador
setwd("C:/Users/dmpm/Documents/PowerBI/Cap12")
getwd()

# Carregando os dados
?read.table
dados <- read.table("Usuarios.csv",
                    dec = ".",
                    sep = ",",
                    h = T,
                    fileEncoding = "windows-1252")

# Visualizando e sumarizando os dados
View(dados)
names(dados)
str(dados)
summary(dados$salario)
summary(dados$grau_instrucao)
mean(dados$salario)
mean(dados$grau_instrucao)

# Tabela de Frequ�ncias Absolutas
freq <- table(dados$grau_instrucao)
View(freq)

# Tabela de Frequ�ncias Relativas
freq_rel <- prop.table(freq)
View(freq_rel)

# Porcentagem (100 * freq_rel_table)
p_freq_rel <- 100 * prop.table(freq_rel)
View(p_freq_rel)

# Adiciona linhas de total
View(freq)
freq <- c(freq, sum(freq))
View(freq)
names(freq)[4] <- "Total"
View(freq)

# Tabela final como todos os valores

# Calculamos frequ�ncia relativa e frequ�ncia proporcional
freq_rel <- c(freq_rel, sum(freq_rel))
p_freq_rel <- c(p_freq_rel, sum(p_freq_rel))

# Tabela final com todos os vetores
tabela_final <- cbind(freq,
                      freq_rel = round(freq_rel, digits = 2),
                      p_freq_rel = round(p_freq_rel, digits = 2))
View(tabela_final)


setwd("~/Documents/Projects/UA_FAIRBANKS/dendrometer/data/20160822_newPwrTest/")
data = data.frame(read.csv("102_1.csv"))
names(data) <- c("sensor_num", "time", "val", "temp", "batt_v", "Ev", "n_at")
data$time_real = as.POSIXct(data$time, origin="1970-01-01") #Convert time to POSIX

Vref = 2.048 #ADC Voltage Reference
N = 16 #ADC Set to 16 bit resolution
LSB = ((2*Vref)/2^N) #Least Significant Bit (in volts)
PGA = 1 #Programmable Gain Amplifier (Set to 1)
L = 50 #Length of Linear Sensor
data$Iv = data$val*(LSB/PGA) #Caluclate Input Voltage (Iv)
data$position = ((data$Iv/data$Ev)*L) #Calculate Position of Slider

plot(data$batt_v~data$time_real)
plot(data$Ev_volts~data$time_real)
data$Ev_volts = data$Ev * (3.3 / 1023)


### Advanced Factor Functions V1.05  2013/03/20
### 2013 James H. Steiger
packageLoaded <- function(name) 0 != length(grep(paste("^package:",
                                                       name, "$", sep=""), search()))

if(!packageLoaded("plotrix")) library(plotrix)
if(!packageLoaded("sem")) library(sem)

# This code block includes R code for
#
# Gradient Projection Algorithms and Software for Arbitrary
# Rotation Criteria in Factor Analysis.
#
# by:
#
# Coen A. Bernaards and Robert I. Jennrich.
#
# Website: http://www.stat.ucla.edu/research
#

# GPForth is the main GP algorithm for orthogonal rotation.
# GPFoblq is the main GP algorithm for oblique rotation.
# For both algorithms is required: a loadings matrix A. Optional
# a initial rotation matrix Tmat. By default this is the identity matrix.
# Optional: the rotation method to be used. Between quation marks have to
# be the last part of the name of the vgQ function, e.g. for vgQ.varimax
# the argument is "varimax". Identical arguments can be used for oblique
# rotation. Some rotation criteria (including simplimax, pst, procrustes,
# cf,...) require one or more additional arguments. For example, simplimax
# needs the number of 'close to zero loadings'. This is given included as
# the extra argument k=27. Check out the rotation methods for details.
# When a new rotation method is implemented, and it needs an additional
# argument then this is the easiest way to pass it to the function.
#
# New rotation methods need to be programmed as vgQ.newmethod. The only
# inputs are the matrix L, and potential additional arguments. The
# output consists of the value f  of the criterion, its gradient Gq at L,
# and the name of the method.

GPForth <- function(A,Tmat=diag(ncol(A)),method="varimax",...){
 al <- 1
  L  <- A %*% Tmat
  VgQ <- get(paste("vgQ",method,sep="."))(L,...)
  G <- crossprod(A,VgQ$Gq)
  f <- VgQ$f
  Table <- NULL
  for (iter in 0:500){
    M <- crossprod(Tmat,G)
    S <- (M+t(M))/2
    Gp <- G - Tmat %*% S
    s <- sqrt(sum(diag(crossprod(Gp))))
    Table <- rbind(Table,c(iter,f,log10(s),al))
    if (s < 1e-5)
      break
    al <- 2*al
    for (i in 0:10){
      X <- Tmat - al * Gp
      UDV <- svd(X)
      Tmatt <- UDV$u %*% t(UDV$v)
      L <- A %*% Tmatt
      VgQt <- get(paste("vgQ",method,sep="."))(L,...)
      if (VgQt$f < (f-.5*s^2*al))
        break
      al <- al/2
    }
    Tmat <- Tmatt
    f <- VgQt$f
    G <- crossprod(A,VgQt$Gq)
  }
  Th <- Tmat
  Lh <- L
  method <- VgQ$Method
  orthogonal <- T
  ## Added by Steiger
  colnames(Table) <- c("Iteration", "Function", "Log10(s)","Alpha")
  ##
  return(list(Lh=Lh,Th=Th,Table=Table,method=method,orthogonal=orthogonal))
}

GPFoblq <- function(A,Tmat=diag(ncol(A)),method="quartimin",...){
  al <- 1
  L <- A %*% t(solve(Tmat))
  VgQ <- get(paste("vgQ",method,sep="."))(L,...)
  G <- -t(t(L) %*% VgQ$Gq %*% solve(Tmat))
  f <- VgQ$f
  Table <- NULL
  for (iter in 0:500){
    Gp <- G-Tmat %*% diag(apply(Tmat*G,2,sum))
    s <- sqrt(sum(diag(crossprod(Gp))))
    Table <- rbind(Table,c(iter,f,log10(s),al))
    if (s < 1e-5)
      break
    al <- 2*al
    for (i in 0:10){
      X <- Tmat-al*Gp
      v <- 1/sqrt(apply(X^2,2,sum))
      Tmatt <- X %*% diag(v)
      L <- A %*% t(solve(Tmatt))
      VgQt <- get(paste("vgQ",method,sep="."))(L,...)
      if (VgQt$f < (f-.5*s^2*al))
        break
      al <- al/2
    }
    Tmat <- Tmatt
    f <- VgQt$f
    G <- -t(t(L) %*% VgQt$Gq %*% solve(Tmatt))

  }
  Th <- Tmat
  Lh <- L
  Phi <- t(Tmat) %*% Tmat
  method <- VgQ$Method
  orthogonal <- F
  return(list(Lh=Lh,Phi=Phi,Th=Th,Table=Table,method=method,orthogonal=orthogonal))
}

vgQ.quartimin <- function(L){
  Method="Quartimin"
  L2 <- L^2
  k <- ncol(L)
  M <- matrix(1,k,k)-diag(k)
  f <- sum(L2 * (L2 %*% M))/4
  Gq <- L * (L2 %*% M)
  return(list(Gq=Gq,f=f,Method=Method))
}

vgQ.oblimin <- function(L,gam=0){
  Method <- paste("Oblimin g=",gam,sep="")
  if (gam == 0) Method <- "Oblimin Quartimin"
  if (gam == .5) Method <- "Oblimin Biquartimin"
  if (gam == 1) Method <- "Oblimin Covarimin"
  k <- ncol(L)
  p <- nrow(L)
  N <- matrix(1,k,k)-diag(k)
  f <- sum(L^2 * (diag(p)-gam*matrix(1/p,p,p)) %*% L^2 %*% N)/4
  Gq <- L * ((diag(p)-gam*matrix(1/p,p,p)) %*% L^2 %*% N)
  return(list(Gq=Gq,f=f,Method=Method))
}

vgQ.target <- function(L,Target){
  Method <- "Target rotation"
  # Needs Target matrix, e.g.  Target <- matrix(c(rep(9,4),rep(0,8),rep(9,4)),8)
  f <- sum((L-Target)^2)
  Gq <- 2*(L-Target)
  return(list(Gq=Gq,f=f,Method=Method))
}

vgQ.pst <- function(L,W,Target){
  Method <- "Partially specified target"
  # Needs weight matrix W with 1's at specified values, 0 otherwise
  # e.g. W = matrix(c(rep(1,4),rep(0,8),rep(1,4)),8).
  # When W has only 1's this is procrustes rotation
  # Needs a Target matrix Target with hypothesized factor loadings.
  # e.g. Target = matrix(0,8,2)
  Btilde <- W * Target
  f <- sum((W*L-Btilde)^2)
  Gq <- 2*(W*L-Btilde)
  return(list(Gq=Gq,f=f,Method=Method))
}

vgQ.oblimax <- function(L){
  Method <- "Oblimax"
  f <- -(log(sum(L^4))-2*log(sum(L^2)))
  Gq <- -(4*L^3/(sum(L^4))-4*L/(sum(L^2)))
  return(list(Gq=Gq,f=f,Method=Method))
}

vgQ.entropy <- function(L){
  Method <- "Minimum entropy"
  f <- -sum(L^2 * log(L^2 + (L^2==0)))/2
  Gq <- -(L * log(L^2 + (L^2==0)) + L)
  return(list(Gq=Gq,f=f,Method=Method))
}

vgQ.quartimax <- function(L){
  Method <- "Quartimax"
  f <- -sum(diag(crossprod(L^2)))/4
  Gq <- -L^3
  return(list(Gq=Gq,f=f,Method=Method))
}

vgQ.varimax <- function(L){
  Method <- "Varimax"
  QL <- sweep(L^2,2,apply(L^2,2,mean),"-")
  f <- -sqrt(sum(diag(crossprod(QL))))^2/4
  Gq <- -L * QL
  return(list(Gq=Gq,f=f,Method=Method))
}

vgQ.simplimax <- function(L,k=nrow(L)){
  Method <- "Simplimax"
  # m: Number of close to zero loadings
  Imat <- sign(L^2 <= sort(L^2)[k])
  f <- sum(Imat*L^2)
  Gq <- 2*Imat*L
  return(list(Gq=Gq,f=f,Method=Method))
}

vgQ.bentler <- function(L){
  Method <- "Bentler's criterion"
  L2 <- L^2
  M <- crossprod(L2)
  D <- diag(diag(M))
  f <- -(log(det(M))-log(det(D)))/4
  Gq <- -L * (L2 %*% (solve(M)-solve(D)))
  return(list(Gq=Gq,f=f,Method=Method))
}

vgQ.tandemI <- function(L){  # Tandem Criterion, Comrey, 1967.
  Method <- "Tandem I"
  LL <- (L %*% t(L))
  LL2 <- LL^2
  f <- -sum(diag(crossprod(L^2, LL2 %*% L^2)))
  Gq1 <- 4 * L *(LL2 %*% L^2)
  Gq2 <- 4 * (LL * (L^2 %*% t(L^2))) %*% L
  Gq <- -Gq1 - Gq2
  return(list(Gq=Gq,f=f,Method=Method))
}

vgQ.tandemII <- function(L){  # Tandem Criterion, Comrey, 1967.
  Method <- "Tandem II"
  LL <- (L %*% t(L))
  LL2 <- LL^2
  f <- sum(diag(crossprod(L^2, (1-LL2) %*% L^2)))
  Gq1 <- 4 * L *((1-LL2) %*% L^2)
  Gq2 <- 4 * (LL * (L^2 %*% t(L^2))) %*% L
  Gq <- Gq1 - Gq2
  return(list(Gq=Gq,f=f,Method=Method))
}

vgQ.geomin <- function(L,eps=.01){
  Method <- "Geomin"
  k <- ncol(L)
  p <- nrow(L)
  L2 <- L^2+eps
  pro <- exp(apply(log(L2),1,sum)/k)
  f <- sum(pro)
  Gq <- (2/k)*(L/L2)*matrix(rep(pro,k),p)
  return(list(Gq=Gq,f=f,Method=Method))
}

vgQ.cf <- function(L,kappa=0){
  k <- ncol(L)
  p <- nrow(L)
  # kappa <- 0 # Quartimax
  # kappa <- 1/p # Varimax
  # kappa <- m/(2*p) # Equamax
  # kappa <- (m-1)/(p+m-2) # Parsimax
  # kappa <- 1 # Factor parsimony
  Method <- paste("Crawford-Ferguson:k=",kappa,sep="")
  N <- matrix(1,k,k)-diag(k)
  M <- matrix(1,p,p)-diag(p)
  L2 <- L^2
  f1 <- (1-kappa)*sum(diag(crossprod(L2,L2 %*% N)))/4
  f2 <- kappa*sum(diag(crossprod(L2,M %*% L2)))/4
  f <- f1 + f2
  Gq <- (1-kappa) * L * (L2 %*% N) + kappa * L * (M %*% L2)
  return(list(Gq=Gq,f=f,Method=Method))
}

vgQ.infomax <- function(L){
  Method <- "Infomax"
  k <- ncol(L)
  p <- nrow(L)
  S <- L^2
  s <- sum(S)
  s1 <- apply(S, 1, sum)
  s2 <- apply(S, 2, sum)
  E <- S/s
  e1 <- s1/s
  e2 <- s2/s
  Q0 <- sum(-E * log(E))
  Q1 <- sum(-e1 * log(e1))
  Q2 <- sum(-e2 * log(e2))
  f <- log(k) + Q0 - Q1 - Q2
  H <- -(log(E) + 1)
  alpha <- sum(S * H)/s^2
  G0 <- H/s - alpha * matrix(1, p, k)
  h1 <- -(log(e1) + 1)
  alpha1 <- s1 %*% h1/s^2
  G1 <- matrix(rep(h1,k), p)/s - as.vector(alpha1) * matrix(1, p, k)
  h2 <- -(log(e2) + 1)
  alpha2 <- h2 %*% s2/s^2
  G2 <- matrix(rep(h2,p), ncol=k, byrow=T)/s - as.vector(alpha2) * matrix(1, p, k)
  Gq <- 2 * L * (G0 - G1 - G2)
  return(list(Gq=Gq,f=f,Method=Method))
}

vgQ.mccammon <- function(L){
  Method <- "McCammon entropy"
  k <- ncol(L)
  p <- nrow(L)
  S <- L^2
  M <- matrix(1,p,p)
  s2 <- apply(S, 2, sum)
  P <- S / matrix(rep(s2,p),ncol=k,byrow=T)
  Q1 <- -sum(P * log(P))
  H <- -(log(P) + 1)
  R <- M %*% S
  G1 <- H/R - M %*% (S*H/R^2)
  s <- sum(S)
  p2 <- s2/s
  Q2 <- -sum(p2 * log(p2))
  h <- -(log(p2) + 1)
  alpha <- h %*% p2
  G2 <- rep(1,p) %*% t(h)/s - as.vector(alpha)*matrix(1,p,k)
  Gq <- 2*L*(G1/Q1 - G2/Q2)
  Q <- log(Q1) - log(Q2)
  return(list(Gq=Gq,f=Q,Method=Method))
}

#
# GPromax is a separate function!!!
# Call directly from command prompt.
# R code only.
#
GPromax <- function(A,pow=3){
  method <- "Promax"
  # Initial rotation: Standardized Varimax
  #require(mva)
  xx <- promax(A,pow)
  Lh <- xx$loadings
  Th <- xx$rotmat
  orthogonal <- F
  Table <- NULL
  return(list(Lh=Lh,Th=Th,Table=NULL,method,orthogonal=orthogonal))
}

##
## UTILITY FUNCTIONS

##

# Kaisers standardized variables

# Can be used for standardization and de-standardization.

# For standardization: only provide 1 argument: the matrix A

# output: standardized A and weights W

# For destandardization: provide 2 arguments: matrix A

# and weights W.

# output: destandardized A and weights W.

Standardize <- function(A,W){

  if (nargs()==1)

    W <- sqrt(apply(A^2,1,sum))
  else

    W <- 1/W

  A <- sweep(A,1,W,"/")

  return(A,W)
}

# Random Start

# k: number of dimensions

# orthogonal random start? (Yes, by default).

Random.Start <- function(k,orthogonal=T){

  mat <- matrix(rnorm(k*k),k)

  if (orthogonal){
    ans <- qr.Q(qr(mat))
  }

  else{

    ans <- mat %*% diag(sqrt(1/diag(t(mat) %*% mat)))

  }

  ans

}

########## Following routines added by Steiger

vgQ.bifactor <- function(L){
  Method <- "bifactor"
  k <- dim(L)[2]
  p <- dim(L)[1]
  L <- L[,2:k]
  Lsq <- L * L
  M <- matrix(1,k-1,k-1) - diag(k-1)
  f <- sum(Lsq * (Lsq %*% M))
  zero <- matrix(0,p,1)
  Gq <- 4*cbind(zero, L * (Lsq %*% M))
  return(list(Gq=Gq,f=f,Method=Method))
}

################  End of Augmented Jennrich-Bentler Functions ############

################ The following code block augments some service
################ functions for Exploratory Factor Analysis with R
##########################################################################

sx2 <- function(df, lambda)
{
  x <- 2 * df + 4 * lambda
  if(x<0)x<-0
  return(sqrt(x))
}

FindLambda <- function(X2Observed,Df,CumP)
{

##should get symbolic integer codes for droot_c
##compute rough approximation to the start value
  ErrorCondition <- FALSE
  if (pchisq(X2Observed, Df) < CumP)
  {
    print("No non-negative value of Lambda will produce the desired cumulative probability.")
    return(NA)
  }
  zgoal <- qnorm(CumP)
  df <- Df
  lambda1 <- X2Observed - df
  if(lambda1 < 0) lambda1 <- 0
  s1 <- sx2(df, lambda1)
  lambda2 <- lambda1 - s1 * zgoal  ##temporary guess for lambda2
  s2 <- sx2(df, lambda2)
  s_est <- (s1 + s2) / 2
  lambda2 <- lambda1 - zgoal * s_est
  if(lambda2 < 0) lambda2 <- 0
  pp2<-pchisq(X2Observed, Df, lambda2)-CumP
  s1 <- sx2(df,lambda2)
  z <-( X2Observed - df - lambda2)/s1
  lambda3 <- lambda2 - s1 * (z-zgoal)  ##temporary guess for lambda2
  s2 <- sx2(df, lambda3)
  s_est <- (s1 + s2) / 2
  lambda3 <- lambda2 - (z-zgoal) * s_est
  if(lambda3 < 0)
  {
    lambda3 <- 0
  }
  pp3<-pchisq(X2Observed, Df, lambda3)-CumP
  ##   should be in a linear range by now
  if((pp2-pp3)!= 0)
  {
    xstart <- lambda3 - pp3 * ((lambda2-lambda3)/(pp2-pp3))
  }
  n<-1
  maxit<-10000
  step<-1.e-4
  eps<-1.e-10

  xstart<-max(xstart,1)
  if(abs(pchisq(X2Observed, Df)-CumP) <= eps)
  {
    return(0)
  }
  xold<-0
  xc<-xstart
  fc<-pchisq(X2Observed, Df, xc)-CumP
  if(ErrorCondition)
  {
    return(NA)
  }
  hc<-max(step*xc,eps)
  xnew<-xc-hc
  fnew<-pchisq(X2Observed, Df, xnew)-CumP
  if(ErrorCondition)
  {
    return(NA)
  }
  ac<-(fc-fnew)/hc
  while ( abs(xnew-xold) > eps && n < maxit && abs(fc) > eps && abs(ac) >= 1.e-35)
  {
    n<-n+1
    xnew<-xc-fc/ac
    xold<-xc
    fold<-fc
    xc<-xnew
    fc<-pchisq(X2Observed, Df, xnew)-CumP
    ac<-(fold-fc)/(xold-xc)
    if(ErrorCondition)
    {
      return(NA)
    }

  }
  ##iteration complete
  if( (n >= maxit)||(abs(fc) > eps))
  {
    ErrorCondition <- TRUE
    print("Percentage point convergence failure.")
    return(NA)
  }
  else
  {
    return(xc)
  }
}
ChiSquare.Lambda.CI <- function(X2Observed,Df,Confidence=.90){
  p <- (1. - Confidence)/2.
  if( pchisq(X2Observed, Df) <= p)
{
    Upper <- 0.
    Lower <- 0.
    return(c(Lower,Upper))
  }
     Upper <- FindLambda(X2Observed,Df,p)
     if(pchisq(X2Observed, Df) <= 1.-p)
     {
       Lower  <- 0
       return(c(Lower,Upper))
     }
     Lower <- FindLambda(X2Observed,Df,1-p)
     return(c(Lower,Upper))
}

rmsea.ci <- function(chisq,df,n,conf=.90){
  options(warn=-1)
  sample.rmsea <- sqrt(max(((chisq-df)/(n-1)),0)/df)
#  out <- conf.limits.nc.chisq(Chi.Square=chisq,conf.level=conf,df=df,Jumping.Prop=0.001)
  out<-ChiSquare.Lambda.CI(chisq,df,conf)
  lower <- if(is.na(out[1])) 0 else out[1]
  upper <- if(is.na(out[2])) 0 else out[2]
  lower <- sqrt(lower/(n-1)/df)
  upper <- sqrt(upper/(n-1)/df)
  results <- list(Lower.Limit= lower,
                  Point.Estimate = sample.rmsea,
                  Upper.Limit = upper,
                  Confidence.Level = conf)
  return((results))
}

compute_CFI <- function(chi_null,df_null,chi_model,df_model){
  d_null <- chi_null - df_null
  d_model <- chi_model - df_model
  (cfi <- (d_null - d_model) / d_null)
  return(cfi)
}

compute_TLI <- function(chi_null,df_null,chi_model,df_model){
  (r_null <- chi_null/df_null)
  (r_model <- chi_model/df_model)
  (tli <- (r_null - r_model)/((r_null)-1))
  return(tli)
}

fa_stats <- function(Correlation.Matrix,n.obs,n.factors,conf=.90,
                     maxit=1000,RMSEA.cutoff=NULL,
                     main="RMSEA Plot",sub=NULL){
  # browser()
  runs <- length(n.factors)
  R <- Correlation.Matrix
  maxfac <- max(n.factors)
  res <- matrix(NA,runs,10)
  roots <- eigen(R)$values
  for(i in 1:runs){
    # i <- 3
    # R <- R0
    # n.obs = 643
    # n.factors=3:5
    # maxit = 1000
    output <- factanal(covmat=R,n.obs=n.obs,factors=n.factors[i],maxit=maxit)
    fit <- psych::fa(R,nfactors=n.factors[i],n.obs=n.obs,fm="ml")
    X2 <- output$STATISTIC
    df <- output$dof
    ci <- rmsea.ci(X2,df,n.obs,conf)
    pvar <- sum(roots[1:n.factors[i]])
    # cfi  <- compute_CFI(fit$null.chisq,fit$null.dof,fit$chi, fit$dof)
    # tli  <- compute_TLI(fit$null.chisq,fit$null.dof,fit$chi, fit$dof)
    cfi  <- compute_CFI(fit$null.chisq,fit$null.dof,X2, df)
    tli  <- compute_TLI(fit$null.chisq,fit$null.dof,X2, df)
    v <- c(n.factors[i],pvar,X2,df,1-pchisq(X2,df),ci$Point.Estimate,
           ci$Lower.Limit,ci$Upper.Limit, cfi,tli)

    res[i,] <- v
  }
  colnames(res)=c("Factors","Cum.Eigen","Chi-Square","Df","p.value",
                  "RMSEA.Pt","RMSEA.Lo","RMSEA.Hi","CFI","TLI")
  plotCI(n.factors,res[,6],li = res[,7],ui=res[,8],
         ylab="RMSEA",xlab="Number of Factors",main=main,
         sub=sub)
  lines(n.factors,res[,6],col="blue")
  abline(h=0,col="black",lty=3)
  abline(h=RMSEA.cutoff,col="red",lty=2)

  return(res)
}

FA.Stats <- function(
  Correlation.Matrix,
  n.obs,
  n.factors,
  conf=.90,
  maxit=1000,
  RMSEA.cutoff=NULL,
  main="RMSEA Plot",
  sub=NULL
){
  # browser()
  runs <- length(n.factors)
  R <- Correlation.Matrix
  maxfac <- max(n.factors)
  res <- matrix(NA,runs,8)
  roots <- eigen(R)$values
  for(i in 1:runs){
     output <- stats::factanal(
       covmat=R,
       n.obs=n.obs,
       factors=n.factors[i],
       maxit=maxit
     )
     X2 <- output$STATISTIC
     df <- output$dof
     ci <- rmsea.ci(X2,df,n.obs,conf)
     pvar <- sum(roots[1:n.factors[i]])
     v <- c(
       n.factors[i],
       pvar,
       X2,
       df,
       1-pchisq(X2,df),
       ci$Point.Estimate,
       ci$Lower.Limit,
       ci$Upper.Limit
     )
     res[i,] <- v
  }
  colnames(res)=c("Factors","Cum.Eigen","Chi-Square","Df","p.value",
                      "RMSEA.Pt","RMSEA.Lo","RMSEA.Hi")
  plotCI(n.factors,res[,6],li = res[,7],ui=res[,8],
         ylab="RMSEA",xlab="Number of Factors",main=main,
         sub=sub)
  lines(n.factors,res[,6],col="blue")
  abline(h=0,col="black",lty=3)
  abline(h=RMSEA.cutoff,col="red",lty=2)
  return(res)
}

Scree.Plot <- function(R,main="Scree Plot",sub=NULL){
  roots <- eigen(R)$values
  x <- 1:dim(R)[1]
  plot(x,roots,type="b",col='blue',ylab="Eigenvalue",
       xlab="Component Number",main=main,sub=sub)
  abline(h=1,lty=2,col="red")

}
# Scree.PlotGG <- function(R, main="Scree Plot",sub=NULL){
#   roots <- eigen(R)$values
#   x <- 1:dim(R)[1]
# #   plot(x,roots,type="b",col='blue',ylab="Eigenvalue",
# #        xlab="Component Number",main=main,sub=sub)
# #   abline(h=1,lty=2,col="red")
#
#   ds <- data.frame(x=x, roots=roots)
#   g <- ggplot(ds, aes(x=x, y=roots)) +
#     geom_rect(ymax=1, ymin=-Inf, xmin=-Inf, xmax=Inf, fill="red") +
#     geom_line(size=1.5, color="blue", na.rm = TRUE) +
#     geom_point(size=5, color="darkblue", na.rm = TRUE) +
#     labs(title=main, x="Component Number", y="Eigenvalue") +
#     theme_bw()
#
#   print(g)
# }

FindBifactor <- function(A,reps){
  warn=-1
  results <- rep( list(list()), reps )
  criterion <- rep(NA,reps)
  m <- dim(A)[2]
  for(i in 1:reps) {
    x <- GPForth(A,method="bifactor",Tmat = Random.Start(m))
    criterion[i] <- min(x$Table[,2])
    results[[i]] <- x
  }
  j <- order(criterion)[1]
  warn=1
  return(results[[j]])
}

FindBestPattern <- function(A,method,is.oblique=FALSE,reps=15){
  results <- rep( list(list()), reps )
  criterion <- rep(NA,reps)
  m <- dim(A)[2]
  for(i in 1:reps) {
    if(!is.oblique)x <- GPForth(A,method=method,Tmat = Random.Start(m))else
      x <- GPFoblq(A,method=method,Tmat=Random.Start(m))
    criterion[i] <- min(x$Table[,2])
    results[[i]] <- x
  }
  j <- order(criterion)[1]
  return(results[[j]])
}

FixPattern <- function(res,sort=TRUE){
  F <- res$Lh
  p <- dim(F)[1]
  m <- dim(F)[2]
  factor.names <- paste("Factor",1:m,sep="")
  one.prime <- matrix(1,1,p)
  F.sign <- as.vector(sign(one.prime %*% F))
  #  cat("\nLoadings:\n")
#  fx <- format(round(Lambda, digits))
#  names(fx) <- NULL
#  nc <- nchar(fx[1L], type="c")
#  fx[abs(Lambda) < cutoff] <- paste(rep(" ", nc), collapse = "")
#  print(fx, quote = FALSE, ...)
#  F <- Lambda
#fix signs
  Lambda <- F
  Lambda <- Lambda %*% diag(F.sign)
#sort columns by SS loadings
  mx <- diag(t(Lambda)%*%Lambda)
  ind <- order(mx,decreasing=TRUE)
  Lambda <- Lambda[,ind]
#  browser()
#  print(res$orthogonal)
#  print(res$Phi)
  if(!res$orthogonal)
  {
#   fix up Phi
   Phi <- diag(F.sign) %*% res$Phi %*% diag(F.sign)
   Phi <- Phi[ind,]
   Phi <- Phi[,ind]
  }
  if (sort) {
    mx <- max.col(abs(Lambda))
    ind <- cbind(1L:p, mx)
    mx[abs(Lambda[ind]) < 0.4] <- m + 1
    Lambda <- Lambda[order(mx, 1L:p),]
  }
  colnames(Lambda) <- factor.names
  res$Lh <- Lambda
  if(!res$orthogonal)
  {
  colnames(Phi) <- factor.names
  rownames(Phi) <- factor.names
  res$Phi <- Phi
  }
  return(res)
}

# FindBifactorPattern is not used anywhere else in this code
FindBifactorPattern <- function(A,reps,digits=2) {
  options(warn=-1)
  p<-dim(A)[1]
  out <- FindBifactor(A,reps)
  F <- out$Lh
  one.prime <- matrix(1,1,p)
  F.sign <- as.vector(sign(one.prime %*% F))
  F <- F %*% diag(F.sign)
  options(warn=1)
  return(round(F,digits))
}

GPromax <- function(A,pow=3){
  method <- "Promax"
  # Initial rotation: Standardized Varimax
  xx <- promax(A,pow)
  Lh <- xx$loadings
  Th <- xx$rotmat
  orthogonal <- F
  Table <- NULL
  Tinv <- solve(Th)
  Phi <- Tinv %*% t(Tinv)
  return(list(Lh=Lh,Phi=Phi,Th=Th,Table=NULL,method,orthogonal=orthogonal))
}

print.FLS <- function(x, sort=TRUE, num.digits=3, cutoff=.25, ...)
{
  Lambda <- unclass(x$F)

  p <- nrow(Lambda)
  factors <- ncol(Lambda)
  if (sort) {
    mx <- max.col(abs(Lambda))
    ind <- cbind(1L:p, mx)
    mx[abs(Lambda[ind]) < 0.5] <- factors + 1
    Lambda <- Lambda[order(mx, 1L:p),]
  }
  fx <- format(round(Lambda, num.digits))
  names(fx) <- NULL
  nc <- nchar(fx[1L], type="c")
  fx[abs(Lambda) < cutoff] <- paste(rep(" ", nc), collapse = "")
  print(fx, quote = FALSE, ...)
  vx <- colSums(Lambda^2)
  varex <- rbind("SS loadings" = vx)
  if(is.null(attr(x, "covariance"))) {
    varex <- rbind(varex, "Proportion Var" = vx/p)
    if(factors > 1)
      varex <- rbind(varex, "Cumulative Var" = cumsum(vx/p))
  }
  cat("\n")
  print(round(varex, num.digits))

if(!is.null(x$Phi)){
  cat("\nFactor Intercorrelations\n")
  cat("------------------------\n")
  print(round(unclass(x$Phi),num.digits))
  }
 invisible(x)
}

print.MLFA<-function(x,num.digits=3,cutoff=0.25,sort_=TRUE,...)
{
cat("\n## Unrotated\n------------------\n")
print.FLS(x$Unrotated,num.digits=num.digits,cutoff=cutoff,sort=sort_)
cat("\n## Varimax (T)\n------------------\n")
print.FLS(x$Varimax,num.digits=num.digits,cutoff=cutoff,sort=sort_)
cat("\n## Promax (Q)\n-----------------\n")
print.FLS(x$Promax,num.digits=num.digits,cutoff=cutoff,sort=sort_)
cat("\n## Quartimin (Q)\n-----------------\n")
print.FLS(x$Quartimin,num.digits=num.digits,cutoff=cutoff,sort=sort_)
cat("\n## Bifactor (T)Loadings\n---------------------------\n")
print.FLS(x$Bifactor,num.digits=num.digits,cutoff=cutoff,sort=sort_)
cat("\n## Bifactor (Q)\n-------------------------\n")
# print.FLS(x$BifactorOblique,num.digits=num.digits,cutoff=cutoff,sort=sort_)
# # the last element must be invisible for proper output in R
invisible(print.FLS(x$BifactorOblique,num.digits=num.digits,cutoff=cutoff,sort=sort_))

# # Crawford-Ferguson added by Koval
# cat("\nCF Loadings\n-------------------------\n")
# print.FLS(x$CF,num.digits=num.digits,cutoff=cutoff,sort=sort_)
# cat("\nCFQ Loadings\n-------------------------\n")
# # the last element must be invisible for proper output in R
# invisible(print.FLS(x$CFQ,num.digits=num.digits,cutoff=cutoff,sort=sort_))

}

MLFA <- function(Correlation.Matrix=NULL,
                 n.factors=NA,
                 n.obs=NA,
                 data=NULL,
                 Factor.Pattern=NULL,
                 random.starts=15,
                 maxit=1000,
                 num.digits=3,
                 cutoff=0.30,
                 promax.m=3,
                 sort = TRUE)
{
cat("This will take a moment.")
if(!is.null(Correlation.Matrix)&&is.null(data)){
        R <- Correlation.Matrix
        p <- dim(R)[1]
        A <- factanal(covmat=R,n.obs=n.obs,factors=n.factors,maxit=maxit,rotation="none")$loadings[1:p,]
  }
if(!is.null(data)){
        R <- cor(data)
    n.obs <- dim(data)[1]
        p <- dim(R)[1]
        A <- factanal(covmat=R,n.obs=n.obs,factors=n.factors,maxit=maxit,rotation="none")$loadings[1:p,]
}
if(is.null(data)&&is.null(Correlation.Matrix)){
        A <- Factor.Pattern
        p <- dim(A)[1]
}

m <- dim(A)[2]
factor.labels <- paste("Factor",1:m,sep="")
# browser()
# Variamx
A.varimax <- varimax(A)$loadings[1:p,]
res <- list(Lh=A.varimax,orthogonal=TRUE)
res <- FixPattern(res, sort = sort)
A.varimax <- list(F=res$Lh)
# Promax
res <- GPromax(A,pow=promax.m)
res <- list(Lh=res$Lh,Phi=res$Phi,orthogonal=FALSE)
res <- FixPattern(res, sort = sort)
Phi.promax <- res$Phi
A.promax <- list(F=res$Lh,Phi=Phi.promax,orthogonal=FALSE)
cat(".")
# Quartimin
res <- FindBestPattern(A,"quartimin",reps=random.starts,is.oblique=TRUE)
res <- list(Lh=res$Lh,Phi=res$Phi,orthogonal=FALSE)
res <- FixPattern(res, sort = sort)
Phi.quartimin <- res$Phi
A.quartimin <- list(F=res$Lh,Phi = Phi.quartimin)
cat(".")
# Bifactor
res <- FindBestPattern(A,"bifactor",reps=random.starts)
orthogonal=TRUE
res <- list(Lh=res$Lh,Phi=res$Phi,orthogonal=orthogonal)
res <- FixPattern(res, sort = sort)
Phi=NULL
A.bifactor <- list(F=res$Lh,Phi=Phi)
cat(".")
# Bifactor Oblique
res <- FindBestPattern(A,"bifactor",reps=random.starts,is.oblique=TRUE)
res <- list(Lh=res$Lh,Phi=res$Phi,orthogonal=FALSE)
res <- FixPattern(res, sort = sort)
cat(".")
Phi.bifactor.oblique <- res$Phi
A.bifactor.oblique <- list(F=res$Lh,Phi=Phi.bifactor.oblique)
cat(".")

#### ADDitional rotations

# Geomin (orthogonal)
res <- FindBestPattern(A,"geomin",reps=random.starts)
orthogonal=TRUE
res <- list(Lh=res$Lh,Phi=res$Phi,orthogonal=orthogonal)
res <- FixPattern(res, sort = sort)
Phi=NULL
A.geominT <- list(F=res$Lh,Phi=Phi)
cat(".")
# Geomin (Oblique)
res <- FindBestPattern(A,"geomin",reps=random.starts,is.oblique=TRUE)
res <- list(Lh=res$Lh,Phi=res$Phi,orthogonal=FALSE)
res <- FixPattern(res, sort = sort)
cat(".")
Phi.bifactor.oblique <- res$Phi
A.geominQ <- list(F=res$Lh,Phi=Phi.bifactor.oblique)
cat(".")

# # Oblimin
# res <- FindBestPattern(A,"oblimin",reps=random.starts,is.oblique=TRUE)
# res <- list(Lh=res$Lh,Phi=res$Phi,orthogonal=FALSE)
# res <- FixPattern(res, sort = sort)
# Phi.oblimin <- res$Phi
# A.oblimin <- list(F=res$Lh,Phi = Phi.oblimin)
# cat(".")

# # CF added by Koval
# # Crawford-Ferguson
# res <- FindBestPattern(A,"cf",reps=random.starts,is.oblique=FALSE)
# res <- list(Lh=res$Lh,Phi=res$Phi,orthogonal=TRUE)
# res <- FixPattern(res, sort = sort)
# Phi=NULL
# A.cf <- list(F=res$Lh,Phi=Phi)
# cat(".")
# # Crawford-Ferguson Oblique
# res <- FindBestPattern(A,"cf",reps=random.starts,is.oblique=TRUE)
# res <- list(Lh=res$Lh,Phi=res$Phi,orthogonal=FALSE)
# res <- FixPattern(res, sort = sort)
# cat(".")
# Phi.cfq <- res$Phi
# A.cfq <- list(F=res$Lh,Phi=Phi.cfq)
# cat(".")
# browser()
# reconstruct the unrotated solution
A <- list(F=A,Phi=NULL) # line moved from end of the BifactorOblique section
# cat(".")
#
class(A)="FLS"
class(A.varimax)="FLS"
class(A.promax)="FLS"
class(A.quartimin)="FLS"
cat(".exiting\n") # what is this for?
class(A.bifactor)="FLS"
class(A.bifactor.oblique)="FLS"
class(A.geominT) ="FLS"
class(A.geominQ) ="FLS"

# additional rotations
# class(A.cf)="FLS"
# class(A.cfq)="FLS"
# class(A.oblimin) = "FLS"

output<-list(
  Unrotated       = A,
  Varimax         = A.varimax,
  GeominT         = A.geominT,
  Bifactor        = A.bifactor,
  Promax          = A.promax,
  Quartimin       = A.quartimin,
  GeominQ         = A.geominQ,
  BifactorOblique = A.bifactor.oblique
  # Oblimin = A.oblimin
  # CF=A.cf,
  # CFQ=A.cfq
       )
class(output) = "MLFA"
return(output)
}
# end of MLFA function definition

Loadings <- function(x,num.digits=3,cutoff=.25){
  invisible(print.MLFA(x,cutoff=cutoff,num.digits=num.digits))
}

FAtoCFA <-  function(
  x,
  model.name           = "fit",
  cutoff               = 0.30,
  factor.names         = colnames(x$F),
  reference.indicators = FALSE,
  covs                 = paste(factor.names, collapse=",")
){
  # browser()
  F <- x$F
  fname <- paste(model.name,".r",sep="")
  file.create(fname)
  rn <- rownames(F)
  p <- dim(F)[1]
  m <- dim(F)[2]
  line <- rep(" ",m)
  for (j in 1:m) {
    prefix <- paste(factor.names[j],":",sep="")
    count <- sum(abs(F[,j]>cutoff))
    postfix <- rep(" ",count)
    i.postfix <- 0
    for(i in 1:p){
      if(abs(F[i,j])> cutoff){
        i.postfix <- i.postfix + 1
        if(i.postfix<count) postfix[i.postfix] <- paste(rn[i],", ",sep="")else postfix[i.postfix] <- paste(rn[i],"\n",sep="")
      }
    }
    postfix <- paste(postfix,collapse='')
    line[j] <- paste(prefix,postfix)
    cat(line[j],file=fname,append=TRUE)
  }
  cat("\n",file=fname,append=TRUE)
  cstring <- paste(  c("cfa(reference.indicators=reference.indicators,covs=covs,
                       file=\"",fname,"\")"),collapse="")
  cfa.model <- eval(parse(text=cstring))
  return(cfa.model)
}

FAtoREF <-  function(x,R,model.name="fit",factor.names=colnames(x$F),
                     make.start.values=TRUE,cov.matrix=TRUE,num.digits=4){
  F <- round(x$F,num.digits)
  fname <- paste(model.name,".r",sep="")
  file.create(fname)
  Phi <- x$Phi
  rn <- rownames(F)
  p <- dim(F)[1]
  m <- dim(F)[2]
  #  cat(paste(model.name,"<- cfa(reference.indicators=FALSE)\n"))
  line <- rep(" ",p-(m-1))
  ref.position <- rep(NA,m)
  par.number <- 0
  for (j in 1:m)ref.position[j] <- order(F[,j])[p]
## Got reference positions -- if start values are needed, compute them
## Now, construct the transformation matris
## First, pull out F1
  F1 <- F[ref.position[1],]
  for (j in 2:m) F1 <- rbind(F1,F[ref.position[j],])
## Got F1, now compute T and then rotate F and compute Phi
  if(make.start.values){
  T <- solve(F1) %*% diag ( sqrt( diag(F1 %*% t(F1) ) ) )
  F <- F %*% T
  Tinv <- solve(T)
  Phi <- Tinv %*% t(Tinv)
  }
  for (j in 1:m) {
    prefix <- paste(factor.names[j]," -> ",sep="")
    for(i in 1:p){
      postfix <- rn[i]
      non.fixed=TRUE
      line.out=FALSE
      for(jj in 1:m)
      {
        if(i == ref.position[jj]&&jj==j)
        {
          non.fixed=TRUE
          line.out=TRUE}
        if(i == ref.position[jj]&&jj!=j)
          non.fixed=FALSE
      }
      if(non.fixed){

        par.number <- par.number + 1
        par.name <- paste("Theta",as.character(par.number),sep="")
        if(make.start.values)
          sv<-paste(c(", ",as.character(round(F[i,j],num.digits)),"\n"),collapse="")else  sv <- ", NA\n"
        postfix <- paste(c(postfix,", ",par.name,sv),collapse="")
        line.out=TRUE
      }

      if(line.out){
        line <- paste(c(prefix,postfix),collapse="")
        cat(line,file=fname,append=TRUE)
      }
    }
  }
  for(j in 1:m)
  {
    cat(paste(c(factor.names[j]," <-> ",factor.names[j],", NA, 1\n"),collapse=""),file=fname,append=TRUE)
  }
  if(cov.matrix && m>1 )
  {
    ok <- !is.null(Phi)
    for(i in 2:m)
      for(j in 1:(i-1))
      {
        par.number <- par.number + 1
        prefix <- paste(factor.names[i], "<-> ",sep="")
        postfix <- factor.names[j]
        if(make.start.values&&ok)
          sv<-paste(c(", ",as.character(round(Phi[i,j],num.digits)),"\n"),collapse="") else  sv <- ", NA\n"
        par.name <- paste("Theta",as.character(par.number),sep="")
        postfix <- paste(c(postfix,", ",par.name,sv),collapse="")
        cat(paste(c(prefix,postfix),collapse=""),file=fname,append=TRUE)
      }
  }
## add unique variances
  if(is.null(Phi))Phi <- diag(p)
  U2 <- diag(R - F %*% Phi %*% t(F))
  for(i in 1:p){
    par.number <- par.number+1
    prefix <- paste(c(rn[i]," <-> ",rn[i],", "),collapse="")
    par.name <- paste("Theta",as.character(par.number),sep="")
    if(make.start.values)
      sv<-paste(c(", ",as.character(round(U2[i],num.digits)),"\n"),collapse="") else  sv <- ", NA\n"
    cat(paste(c(prefix,par.name,sv),collapse=""),file=fname,append=TRUE)
    }

  cat("\n",file=fname,append=TRUE)
  cstring <- paste(  c("specifyModel(file=\"",fname,"\")"),collapse="")
  sem.model <- eval(parse(text=cstring))
  return(sem.model)
}

FAtoSEM <-  function(
  x,
  model.name          = "fit",
  cutoff              = 0.30,
  factor.names        = colnames(x$F),
  make.start.values   = FALSE,
  cov.matrix          = FALSE,
  num.digits          = 4,
  par.prefix          = c("Theta","Theta"),
  reference.variables = FALSE
){
  F <- round(x$F,num.digits)
  fname <- paste(model.name,".r",sep="")
  file.create(fname)
  cat("\n")
  Phi <- x$Phi
  rn <- rownames(F)
  p <- dim(F)[1]
  m <- dim(F)[2]
  #  cat(paste(model.name,"<- cfa(reference.indicators=FALSE)\n"))
  line <- rep(" ",p-(m-1))
  par.number <- 0
  for (j in 1:m) {
    prefix <- paste(factor.names[j]," -> ",sep="")
    var.count <- 0
    for(i in 1:p){
      postfix <- rn[i]
      if(abs(F[i,j])>cutoff)
      { var.count <- var.count + 1
        if(var.count>1 || !reference.variables){
        par.number <- par.number + 1
        par.name <- paste(par.prefix[1],as.character(par.number),sep="")
        if(make.start.values)
        {sv<-paste(c(", ",as.character(F[i,j]),"\n"),collapse="")}else sv <- ", NA\n"
        postfix <- paste(c(postfix,", ",par.name,sv),collapse="")
        }else{
          postfix <- paste(postfix,",NA,1\n",sep="")
        }
        line <- paste(c(prefix,postfix),collapse="")
        cat(line,file=fname,append=TRUE)
      }
    }
  }
  for(j in 1:m)
  {
    if(!reference.variables){
      cat(paste(c(factor.names[j]," <-> ",factor.names[j],", NA, 1\n"),collapse=""),
           file=fname,append=TRUE)}
}
if(cov.matrix && m>1 )
  {
    ok <- !is.null(Phi)
    for(i in 2:m)
      for(j in 1:(i-1))
      {
        par.number <- par.number + 1
        prefix <- paste(factor.names[i], "<-> ",sep="")
        postfix <- factor.names[j]
        if(make.start.values&&ok)sv<-paste(c(", ",as.character(Phi[i,j]),"\n"),collapse="") else  sv <- ", NA\n"
        par.name <- paste(par.prefix[2],as.character(par.number),sep="")
        postfix <- paste(c(postfix,", ",par.name,sv),collapse="")
        cat(paste(c(prefix,postfix),collapse=""),file=fname,append=TRUE)
      }
  }
  cat("\n",file=fname,append=TRUE)
  cstring <- paste(  c("specifyModel(file=\"",fname,"\")"),collapse="")
  sem.model <- eval(parse(text=cstring))
  return(sem.model)
}

GetPattern <- function(sem.object){
  A <- sem.object$A
  P <- sem.object$P
  p <- sem.object$n
  m <- sem.object$m - p
  F <- A[1:p,(p+1):sem.object$m]
  Phi <- P[(p+1):sem.object$m,(p+1):sem.object$m]
  return(list(F=F,Phi=Phi))
}

SetupCFAPattern <- function(
  R,
  n.factors    = NA,
  factor.names = NULL
){
  p <- dim(R)[1]
  m <- n.factors
  Fp <- matrix(0,p,m)
  rownames(Fp) <- colnames(R)
  if(is.null(factor.names))factor.names <- paste("Factor",1:m,sep="")
  colnames(Fp) <- factor.names
  Fp <- edit(Fp)
  return(list(F=Fp))
} # return Factor pattern that was manually set up in the editor

UseMod <- function(sem.object,loadings.only=TRUE){
  options(warn=-1)
new.path <- CheckMod(sem.object,row.form=TRUE,loadings.only=loadings.only)$NewPath
old.model <- sem.object$semmod
R <- sem.object$S
n.obs <- sem.object$N
new.model <- rbind(old.model,new.path)
class(new.model) <- class(old.model)
fit.object <- sem(new.model,R,n.obs)
return(fit.object)
}

CFAModel <- function(
  R,
  model.name           = "fit",
  n.factors            = NULL,
  factor.names         = NULL,
  cutoff               = 0.30,
  covs                 = TRUE,
  reference.indicators = FALSE
){
 if(is.null(n.factors))n.factors=length(factor.names)
 x <- SetupCFAPattern(R,n.factors,factor.names)
 factor.names <- colnames(x$F)
 if(covs){
   covariances=paste(factor.names, collapse=",")
 }else{covariances=NULL}
 # browser()
model <- FAtoCFA(
  x                    = x,
  model.name           = model.name,
  cutoff               = cutoff,
  factor.names         = factor.names,
  reference.indicators = reference.indicators,
  covs                 = covariances
)
return(model)
}

QuickCFA <- function(
  R,
  n.factors            = NULL,
  n.obs,
  model.name           = "Model0",
  factor.names         = NULL,
  cutoff               =0.30,
  factor.correlations  = FALSE,
  reference.indicators = FALSE)
{
  if(is.null(factor.names))factor.names <- paste("Factor",1:n.factors,sep="")
  model <- CFAModel(
    R,
    model.name,
    n.factors,
    factor.names,
    cutoff,
    covs=factor.correlations,
    reference.indicators
  )
  fit.object <- sem(model,R,n.obs)
  return(fit.object)
}

CheckMod <- function(sem.object,row.form=FALSE,loadings.only=TRUE){
  options(warn=-1)
  mi <- modIndices(sem.object)
  A <- mi$mod.A
  P <- mi$mod.P
  p <- sem.object$n
  m <- sem.object$m - p
  F <- A[1:p,(p+1):sem.object$m]
  par.number <- sem.object$t + 1
  par.name <- paste("AddedTheta",par.number,sep="")
  largest.F <- max(F,na.rm=TRUE)
  largest.P <- 0
  largest.Q <- 0
  if(!loadings.only){
  Q <- P
  P <- P[(p+1):sem.object$m,(p+1):sem.object$m]
  Q <- Q[1:p,1:p]
  largest.P <- max(P,na.rm=TRUE)
  largest.Q <- max(Q,na.rm=TRUE)
  }
  maxes <- c(largest.F,largest.P,largest.Q)
  for(i in 1:3)if(maxes[i]==-Inf)maxes[i]<-0
  max.mod.pos <- order(maxes,decreasing=TRUE)[1]
  if(max.mod.pos == 1){
    arrow <- "->"
    F.pos <- which(F==largest.F,arr.ind=TRUE)
    if(length(F.pos[,1])>1)F.pos <- F.pos[1,]
    postfix <- rownames(F)[F.pos[1]]
    prefix <- colnames(F)[F.pos[2]]
    value <- F[F.pos[1],F.pos[2]]
  }
  if(max.mod.pos==2){
        arrow="<->"
        P.pos <- which(P==largest.P,arr.ind=TRUE)
        if(length(P.pos[,1])>1)P.pos <- P.pos[1,]
        prefix <- colnames(P)[P.pos[1]]
        postfix <- colnames(P)[P.pos[2]]
        value <- P[P.pos[1],P.pos[2]]
  }
  if(max.mod.pos==3){
    arrow="<->"
    Q.pos <- which(Q==largest.Q,arr.ind=TRUE)
    if(length(Q.pos[,1])>1)Q.pos <- Q.pos[1,]
    prefix <- colnames(Q)[Q.pos[1]]
    postfix <- colnames(Q)[Q.pos[2]]
    value <- Q[Q.pos[1],Q.pos[2]]
  }
  path <- paste(c(prefix,arrow,postfix),collapse="")
  if(!row.form)line <- paste(c(path,",",par.name,", NA"),collapse="")else line <- c(path,par.name,", NA")
  fname="added.r"
  file.create(fname)
  cat(line,file=fname)
  output  <- list(NewPath=line,ModIndex=value)
  return(output)
}
CullModel<-function(fit.object,alpha,cull.Phi=FALSE){
  model <- fit.object$semmod
  zcrit <- qnorm(1-alpha/2)
  zval <- summary(fit.object)$coeff$'z value'
  sig <- abs(zval)>zcrit
  par.posn <- fit.object$par.posn
  new.model <- model
  model.length <- dim(model)[1]
  pos<-1
  to.cull <- 0
  is.ok <- rep(TRUE,model.length)
  if(!cull.Phi){
    do.not.cull <- grep("<->",model)
    for(i in 1:length(do.not.cull)){
    is.ok[do.not.cull[i]]<-FALSE
    }
  }
  for(i in 1:length(sig)){
    if(!sig[i]&&is.ok[par.posn[i]]){
      to.cull[pos] <- par.posn[i]
      pos <- pos+1
    }
  }
new.model <- new.model[-to.cull,]
class(new.model) <- class(model)
return(new.model)
}

QuickJoreskog <- function(R,n.factors,n.obs,model.name="model.0",
                          alpha=0.05,use.promax=TRUE,promax.m=3){
  mlfa.object <- MLFA(R,n.factors,n.obs,promax.m=promax.m)
  if(use.promax)x <- mlfa.object$Promax else x <- mlfa.object$Varimax
  ref.model <- FAtoREF(x,R,model.name)
  ref.fit <- sem(ref.model,R,n.obs)
  culled.model <- CullModel(ref.fit,alpha)
  culled.fit <- sem(culled.model,R,n.obs)
  return(culled.fit)
}

GetPrettyPattern <- function(fit.object,cutoff=0.10){
  print.FLS(GetPattern(fit.object),cutoff=cutoff)}

RMSEA <- function(fit.object,conf=0.90){
  n.obs <- fit.object$N
  X2 <- (n.obs-1)*fit.object$criterion
  p <- fit.object$n
  t <- fit.object$t
  df <- p*(p+1)/2 - t
  rmsea.ci(X2,df,n.obs,conf)
}
QuickEFAtoCFA <- function(
  R,
  n.factors,
  n.obs,
  rotation="Varimax",
  model.name="model.0",
  cutoff=0.30,
  alpha=0.05,
  make.start.values=TRUE,
  cov.matrix=TRUE,
  num.digits=4,
  promax.m=3
){
  rotation.list <- c("Varimax","Promax","Quartimin","Bifactor", "BifactorOblique")
  rot <- 0
  for(i in 1:5)
    if(rotation==rotation.list[i]){rot<-i;break}
  if(rot==0){print("Illegal Rotation Method");return()}
  x <- MLFA(R,n.factors,n.obs,cutoff=cutoff,num.digits=num.digits,promax.m=promax.m)
  cstring <- paste(  c("rot.pattern <-x$",rotation),collapse="")
  eval(parse(text=cstring))
  model <- FAtoSEM(rot.pattern,model.name=model.name,cutoff=cutoff,
                   factor.names=colnames(rot.pattern$F),
  make.start.values=make.start.values,cov.matrix=cov.matrix,num.digits=num.digits)
  fit <- sem(model,R,n.obs)
  return(fit)
}
QuickSEM <- function(S = NULL,n.obs=NULL,max.latents = dim(S)[1]){
x <- data.frame(Latent.Variable.Names = rep("",max.latents))
x <- edit(x)
p <- dim(S)[1]
LV <- x$Latent.Variable.Names
LV <- as.character(LV[LV!=""])
n.LV <- length(LV)
F <- matrix(0,n.LV,n.LV)
Lx <-NULL
Ln <-NULL
rownames(F) <- LV
colnames(F) <- LV
F <- edit(F)
cs <- colSums(F)
for(i in 1:n.LV)if(cs[i]==0)F <- F[1:n.LV,-i]
rs <- rowSums(F)
nc <- dim(F)[2]
for(i in 1:n.LV)if(rs[i]==0){
  Lx <- c(Lx,rownames(F)[i])
  F <- F[-i,1:nc]
}
Ln <- rownames(F)
n.Ln <- length(Ln)
n.Lx <- length(Lx)
Lambda.x <- matrix(0,p,n.Lx)
rownames(Lambda.x) <- colnames(S)
colnames(Lambda.x) <- Lx
Lambda.x <- edit(Lambda.x)
cly <- colnames(S)
rs <- rowSums(Lambda.x)
rn <-NULL
for(i in 1:p)if(rs[i]==0)rn <- c(rn,cly[i])
rows.Lambda.y <- length(rn)
Lambda.y <- matrix(0,rows.Lambda.y,n.Ln)
rownames(Lambda.y) <- rn
colnames(Lambda.y) <- Ln
Lambda.y <- edit(Lambda.y)
q <- dim(Lambda.x)[2]
rs <- rowSums(Lambda.x)
LL<-NULL
RR<-NULL
RN<-rownames(Lambda.x)
for(i in 1:p)if(rs[i]>0){
  LL <- rbind(LL,Lambda.x[i,])
  RR <- c(RR,RN[i])
}
Lambda.x <- LL
colnames(Lambda.x)<- Lx
rownames(Lambda.x)<- RR
xxx <- list(F=Lambda.x)
yyy <- list(F=Lambda.y)
mm1 <- FAtoSEM(xxx,"xxx",par.prefix=c("Lamdax","Phi"))
mm2 <- FAtoSEM(yyy,"yyy",reference.variables=TRUE,par.prefix=c("Lambday","Delta"))
struc.model <- FtoSEM(F,Lx,Ln,"sss")
my.model <- rbind(mm1,mm2,struc.model)
class(my.model) <- class(mm1)
sem(my.model,S,n.obs)
}

FtoSEM <- function(F,Lx,Ln,model.name){
  fname <- paste(model.name,".r",sep="")
  file.create(fname)
  cat("\n")
#Get Betas
  #Are there any?
  if(dim(F)[2]>length(Lx)){
  par.prefix <- "Beta"
  lnlist <- colnames(F)
  for(k in 1:length(Lx)){
    for(j in 1:length(lnlist))
      if(Lx[k]==lnlist[j])lnlist[k]<-" "}
  lns <- lnlist[lnlist!=" "]
  bbb=0
## List of prefix names for Betas is in lns
  for(j in 1:length(lns)){
    for(i in 1:length(Ln)){
#      browser()
      if(F[Ln[i],lns[j]]>0){bbb<-bbb+1
      prefix <- paste(c(lns[j],"->",Ln[i]),collapse="")
      par.name <- paste(c(",",par.prefix,as.character(bbb)),collapse="")
      postfix <- ",NA\n"
      }
    }
    line <- paste(c(prefix,par.name,postfix),collapse="")
    cat(line,file=fname,append=TRUE)
  }
  }
#Get Gammas
  gamma<-0
  par.prefix <- "Gamma"
  for(i in 1:length(Lx)){
    for(j in 1:length(Ln))
  {
      if(F[Ln[j],Lx[i]]>0){gamma<-gamma+1
      prefix <- paste(Lx[i],"->",sep="")
      prefix <- paste(prefix,Ln[j],sep="")
      par.name <- paste(c(",",par.prefix,as.character(gamma)),sep="")
      postfix <- ",NA\n"

        line <- paste(c(prefix,par.name,postfix),collapse="")
        cat(line,file=fname,append=TRUE)
  }}}
  cat("\n",file=fname,append=TRUE)
  cstring <- paste(  c("specifyModel(file=\"",fname,"\")"),collapse="")
  sem.model <- eval(parse(text=cstring))
  return(sem.model)

}

EditSEM<- function(sem.object){
  old.model <- sem.object$semmod
  new.model <- edit(old.model)
  return(sem(new.model,sem.object$S,sem.object$N))
}


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

par(omi=c(0.5,0.5,1.1,0.5),family="Lato Light",las=1)
layout(matrix(data=c(1,2,3,4,5),nrow=1,ncol=5),widths=c(2.0,1,1,1,1),heights=c(1,1))

library(gdata)

# Read data and prepare chart

myData<-read.xls("myData/income_five_classes.xlsx",skip=1,dec=".", encoding="latin1")
tmyData<-t(myData)
transparency<-c(0,50,100,150,200)
number_colour<-c("black","black","black","black","white")
pos<-c(45,45,45,45,35)
par(cex=1.05)

# Create chart and other elements

for (i in 1:5) {
if (i == 1)
{
par(mai=c(0.25,1.75,0.25,0.15))
bp1<-barplot(tmyData[ ,i],horiz=T,cex.names=1.6,axes=F,names.arg=gsub("."," ",names(myData),fixed=T),xlim=c(0,60),col=rgb(43,15,52,0,maxColorValue=255))
} else
{
par(mai=c(0.25,0.1,0.25,0.15))
bp2<-barplot(tmyData[ ,i],horiz=T,axisnames=F,axes=F,xlim=c(0,60),col=rgb(200,0,0,transparency[i],maxColorValue=255),border=par("bg"))
}
text(pos[i],bp1,adj=1,labels=paste(round(myData[i ,],digits=0),"%",sep=" "),col=number_colour[i],xpd=T,cex=1.3)
mtext(seq(0,60,by=15),at=seq(0,60,by=15),1,line=0,cex=0.85)
arrows(0,-0.1,0,14.6,lwd=2.5,length=0,xpd=T,col="grey")
}

# Titling

title(main="Income Distribution over five Classes in different Countries",line=3,adj=0,cex.main=1.75,family="Lato Black",outer=T)
myBreak<-strsplit( strwrap("In Mexico the richest 20% of income recipients hold over 64% of the overall income, in Norway
                              the figure is 40%. Compared interntionally Germany is in the upper half.",width=110),"\n")
for(i in seq(along=myBreak))
{
mtext(myBreak[[i]],line=(1.8-i)*1.7,adj=0,side=3,cex=1.25,outer=T)
}
mtext("Source: World Income Inequality Database V2.Oc 2008",1,line=2,adj=1,font=3)
dev.off()