### kClass: Generates k-class estimators (point est, se, p-value, and confint)
###         Must run ivmodel before you run this code
### INPUT: ivmodel, an object from ivmodel() function
###        k, a vector (or scalar) of k values for estimation
###        beta0, a scalar null value for testing and p-values
###        alpha, significance level for confidence intervals
###        heteroSE, use heteroscedastic robust standard errors?
###        clusterID, if cluster-robust standard errors are desired, please provide a vector of
###                   length that's identical to the sample size.
###                   For example, if n = 6 and clusterID = c(1,1,1,2,2,2),
###                   there would be two clusters where the first cluster
###                   is formed by the first three observations and the
###                   second cluster is formed by the last three observations
###                   clusterID can be numeric, character, or factor.
### OUTPUT: a list of point estimate, standard error, test statistic, and p-value
KClass = function(ivmodel,
                  beta0=0,alpha=0.05,k=c(0,1),
                  manyweakSE=FALSE,heteroSE=FALSE,clusterID=NULL) {
  # Error checking
  if(class(ivmodel) != "ivmodel") {
    print("You must supply an ivmodel class. Run ivmodel() and see ivmodel() function for details")
    return(NULL)
  }
  if(missing(k)) {
    print("You must specify a value for k")
    return(NULL)
  }

  # Extract objects from ivmodel
  Y= ivmodel$Y; D = ivmodel$D; Z = ivmodel$Z; ZXQR = ivmodel$ZXQR; p = ivmodel$p
  if(p == 0) W = D
  if(p > 0) W = cbind(D,ivmodel$X)
  degF = ivmodel$n - ivmodel$p - 1 # this looks strange, but it's from Wooldridge and Stock (2002)

  # Compute k-class estimator
  kPointEst = matrix(0,length(k),1+p) # First column is treatment effect, rest are exogeneous covariates estimates.
  kVarPointEst = matrix(0,length(k),1+p)
  kCILower = matrix(0,length(k),1+p)
  kCIUpper = matrix(0,length(k),1+p)

  for(i in 1:length(k)) {
    rankInverse = qrrank(qr(t(W) %*% W - k[i] * t(W) %*% qr.resid(ZXQR,W)))
    if(rankInverse < ncol(W)) stop("k is out-of-range; the matrix inversion in the k-class estimator will fail.")
    inverseMat = solve(t(W) %*% W - k[i] * t(W) %*% qr.resid(ZXQR,W))
    kPointEst[i,] = as.numeric(inverseMat %*% ( t(W) %*% Y - k[i] *t(W) %*% qr.resid(ZXQR,Y)))
    if(1 <= 0) { #k exceeds the maximum possible value
	    kVarPointEst[i,] = NA;
	    kCILower[i,] = c(NA,NA); kCIUpper[i,] = c(NA,NA);
    } else {
        if (manyweakSE && k[i] != 0) { ## From Hansen et al. (2008)
            udelta = as.numeric(Y - W %*% kPointEst[i,])
            sigmahat.sq = sum(udelta^2)/(ivmodel$n-ncol(W))
            alphatilde = sum( qr.fitted(ZXQR,udelta)^2)/sum(udelta^2)
            iotahat = qr.fitted(ZXQR,W)
            Xtilde = W - t(t(udelta)) %*% (t(udelta) %*% W) / sum(udelta^2)
            Vhat = qr.resid(ZXQR,Xtilde)
            Ptt = diag(W %*% solve(t(W) %*% W) %*% t(W))
            kappa = sum(Ptt^2)/ivmodel$L
            tauT = ivmodel$L / ivmodel$n

            H = t(W) %*% qr.fitted(ZXQR,W) - alphatilde * t(W) %*% W
            sigmaB = sigmahat.sq * ( (1-alphatilde)^2 * t(Xtilde) %*% qr.fitted(ZXQR,Xtilde) + alphatilde^2 *  t(Xtilde) %*% qr.resid(ZXQR,Xtilde))
            A_other = matrix(0,1,ncol(sigmaB))
            for(j in 1:ivmodel$n) {
              A_other = A_other + udelta[j]^2 * Vhat[j,,drop=FALSE] / ivmodel$n
            }
            A = matrix(0,nrow(sigmaB),ncol(sigmaB))
            B = matrix(0,nrow(sigmaB),ncol(sigmaB))
            for(j in 1:ivmodel$n) {
              A = A + (Ptt[j] - tauT) * (t(iotahat[j,,drop=FALSE]) %*% A_other)
              B = B + (udelta[j]^2 - sigmahat.sq) * (t(Vhat[j,,drop=FALSE]) %*% Vhat[j,,drop=FALSE])
            }
            B = ivmodel$L * (kappa - tauT) * B / (ivmodel$n*(1-2*tauT + kappa * tauT))
            Sigmahat = sigmaB + A + t(A) + B

            Hinv = solve(H)
            Lambdahat = Hinv  %*% Sigmahat %*% Hinv
            kVarPointEst[i,] = diag(Lambdahat)
            print("hello world")

        } else if (heteroSE || (manyweakSE &&k[i] == 0)) {
          inner = matrix(0,ncol(W),ncol(W))
          for(j in 1:length(Y)) {
            adjustVec = as.numeric(W[j,]) - as.numeric(k[i]*qr.resid(ZXQR,W)[j,])
            inner = inner + (Y[j] - sum(W[j,] * kPointEst[i,]))^2 * (t(t(adjustVec)) %*% t(adjustVec) )
          }
          kVarPointEst[i,] = diag(inverseMat %*% inner %*% inverseMat)
	      } else if(!is.null(clusterID)){
	  	    if(length(clusterID) != ivmodel$n) {
	  		    ### Missing problem here needs to be taken care of ###
	  		    print("Cluster ID vector is not the same length as the sample size")
	  		    return(NULL)
	  	    }
	  	    if(!is.character(clusterID) && !is.factor(clusterID) && !is.numeric(clusterID)) {
	  		    print("Cluster ID must be either a character vector, a factor vector, or a numeric vector")
	  		    return(NULL)
	  	    }
	  	    clusterID = as.factor(clusterID)
	  	    clusterID = as.numeric(clusterID)
	  	    nCluster <- length(unique(clusterID)); uniqueclusterID = unique(clusterID)
	  	    inner = matrix(0,ncol(W),ncol(W))
	  	    for(j in uniqueclusterID) {
	  	      clusterSame = which(clusterID == j)
	  	      innerC = rep(0,ncol(W))
	  	      for(t in clusterSame) {
	  	        innerC = innerC + (Y[t] - sum(W[t,] * kPointEst[i,])) *
	  	                      (as.numeric(W[t,]) - as.numeric(k[i]*qr.resid(ZXQR,W)[t,]))
	  	      }
	  	      inner = inner + t(t(innerC)) %*% t(innerC)
	  	    }
	  	    kVarPointEst[i,] = diag(inverseMat %*% inner %*% inverseMat)
	    }
	    else {
	      kVarPointEst[i,] = 1/degF * sum( (Y - W %*% kPointEst[i,])^2) * diag(inverseMat)
	    }
	  # Note that R's AER package uses the z-scores instead of the t distribution. They are basically the same as n gets large.
	    kCILower[i,] = kPointEst[i,] - qt(1-alpha/2,degF) * sqrt(kVarPointEst[i,])
	    kCIUpper[i,] = kPointEst[i,] + qt(1-alpha/2,degF) * sqrt(kVarPointEst[i,])

    }
  }

  # Compute test statistics
  kTestStat = (kPointEst - beta0)/sqrt(kVarPointEst)

  # Compute p-value
  kPValue = 2*(1 - pt(abs(kTestStat),degF))

  # Package output
  kPointEst_trt = matrix(kPointEst[,1],length(k),1)
  kVarPointEst_trt = matrix(sqrt(kVarPointEst)[,1],length(k),1)
  kCI_trt = matrix(c(kCILower[,1],kCIUpper[,1]),length(k),2)
  kPValue_trt = kPValue[,1,drop=FALSE]
  kTestStat_trt = kTestStat[,1,drop=FALSE]

  rownames(kPointEst_trt) = rownames(kVarPointEst_trt) = rownames(kCI_trt) = rownames(kPValue_trt) = rownames(kTestStat_trt) = k
  colnames(kPValue_trt) = colnames(kTestStat_trt) = beta0
  colnames(kPointEst_trt) = "Estimate"
  colnames(kVarPointEst_trt) = "Std. Error"
  colnames(kCI_trt) = c(paste(as.character(round(alpha/2 * 100,1)),"%"),paste(as.character( round((1-alpha/2) * 100,1)),"%"))

  return(list(k = k,
              point.est = kPointEst_trt,std.err = kVarPointEst_trt,test.stat = kTestStat_trt,p.value = kPValue_trt,ci = kCI_trt,
              point.est.other = kPointEst[,-1,drop=FALSE],std.err.other = sqrt(kVarPointEst[,-1,drop=FALSE]),
              test.stat.other = kTestStat[,-1,drop=FALSE],p.value.other = kPValue[,-1,drop=FALSE],
              ci.other.lower = kCILower[,-1,drop=FALSE],ci.other.upper=kCIUpper[,-1,drop=FALSE]))
}


## Likelihood ##
neg.likelihood.SAR.MLE.sigma<-function(para,env)
{
  Y=get("Y",env)
  W=get("W",env)
  theta=para#[1:(length(para)-1)]
  n=length(Y)
  In=diag(length(Y))
  C_theta=theta[1]*W[[1]];if(length(W)>1) {for(i in 2:length(W)) C_theta=C_theta+theta[i]*W[[i]]}
  tmp=In-C_theta
  sigma=sqrt(t(Y-mean(Y)) %*% t(tmp) %*% tmp %*% (Y-mean(Y))/n)  ## At MLE
  eigen.value=eigen(t(tmp) %*% tmp)$value
  eigen.value[abs(eigen.value)<1e-15]=abs(eigen.value[abs(eigen.value)<1e-15]);
  likeli=-n/2*log(sigma^2)+1/2*sum(log(eigen.value))-n/2
  return(as.numeric(-likeli))
}

# first derivatives #
neg.firstderi.SAR.MLE.sigma<-function(para,env)
{
  Y=get("Y",env)
  W=get("W",env)
  result=NULL;
  theta=para#[1:(length(para)-1)]
  #sigma=para[length(para)]
  n=length(Y)
  In=diag(length(Y))
  C_theta=theta[1]*W[[1]];if(length(W)>1) {for(i in 2:length(W)) C_theta=C_theta+theta[i]*W[[i]]}
  tmp=In-C_theta
  sigma=sqrt(t(Y-mean(Y)) %*% t(tmp) %*% tmp %*% (Y-mean(Y))/n)  ## At MLE
  tmp.inv=solve(tmp)
  for(i in 1:length(W))
    result=rbind(result,-psych::tr(tmp.inv %*% W[[i]])+1/sigma^2*t(Y-mean(Y)) %*% tmp %*% W[[i]] %*% (Y-mean(Y)))
  #result=rbind(result,-n/sigma+1/sigma^3*t(Y-mean(Y))%*% tmp %*% tmp %*% (Y-mean(Y)))
  -result
}

## Second Derivatives ##
neg.secondderi.SAR.MLE.sigma<-function(para,env)
{
  Y=get("Y",env)
  W=get("W",env)
  theta=para
  n=length(Y)
  In=diag(length(Y))
  C_theta=theta[1]*W[[1]];if(length(W)>1) {for(i in 2:length(W)) C_theta=C_theta+theta[i]*W[[i]]}
  tmp=In-C_theta
  sigma=sqrt(t(Y-mean(Y)) %*% t(tmp) %*% tmp %*% (Y-mean(Y))/n)  ## At MLE
  tmp.inv=solve(tmp)
  result=matrix(NA,length(para),length(para));
  for(i in 1:length(theta))
    for(j in i:length(theta))
    {
      result[i,j]=result[j,i]=-psych::tr(tmp.inv %*% W[[j]] %*% tmp.inv %*% W[[i]])-1/sigma^2*t(Y-mean(Y)) %*% W[[j]] %*% W[[i]] %*% (Y-mean(Y))
    }
  -result
}

## MML scores ##
mml.dfgps<-function (dfgps_result, intercept = FALSE, stand.coef = FALSE)
{
  N <- dfgps_result$N;
  tau2<-dfgps_result$RSS/N;
  y <- dfgps_result$y;
  y <- y-mean(y)
  k <- dfgps_result$df
  mml_vec <- N * log(2 * pi * tau2) + N + (k+1)*log(sum(y^2)/2/tau2)+log(k+1)-2*gamma((k+3)/2);
  mml_index <- which.min(mml_vec)
  mml_index <- as.integer(mml_index)
  p = dfgps_result$p
  p = as.integer(p)
  delta_t = dfgps_result$delta_t
  delta_t = as.double(delta_t)
  betavec = as.integer(dfgps_result$coefficient_index)
  tuning <- dfgps_result$tuning[mml_index]
  if (stand.coef == FALSE)
    tuning <- dfgps_result$tuning_stand[mml_index]
  beta_mml = msgps::coef.dfgps(dfgps_result, tuning, intercept, stand.coef)$coefficient
  df <- dfgps_result$df[mml_index]
  return(list(result = mml_vec, step = mml_index, tuning = tuning,
              coef = beta_mml, df = df))
}

## optimization ##

SARpredassomain<-function(data,compare='rrblup',assess=TRUE,methods=c("Cp","AICc","GCV","BIC","MML"),max.step=20)
{

  Y=data$train$Y
  W=data$train$IBS
  train.index=data$train.index;

  maxvalue=NULL;
  for(i in 1:length(W))
  {
    tmp=W[[i]];
    maxvalue=c(maxvalue,max(eigen(tmp)$values));
  }
  maxvalue=max(maxvalue);

  ## rescale by sqrt ##
  maxvalue1=maxvalue;
  maxvalue=NULL;
  for(i in 1:length(W))
  {
    data$train$IBS[[i]]=data$train$IBS[[i]]/sqrt(maxvalue1);
    data$IBS[[i]]=data$IBS[[i]]/sqrt(maxvalue1);
    tmp=data$train$IBS[[i]];
    maxvalue=c(maxvalue,max(eigen(tmp)$values));
  }
  maxvalue=max(maxvalue);
  W=data$train$IBS

  env=new.env();
  assign("Y",Y,env);
  assign("W",W,env);

  ## initial estimates ##
  converge=TRUE;
  set.seed(10);
  int1=runif(length(W),-1/maxvalue,1/maxvalue);
  opt1 <- optimx::optimx(int1,neg.likelihood.SAR.MLE.sigma,gr=neg.firstderi.SAR.MLE.sigma, hessian = TRUE,env=env,method="L-BFGS-B",itnmax=5000)
  second<-attr(opt1,"details")[1,]$nhatend;

  if(!opt1$kkt2 | is.na(opt1$kkt2))
  {
    step=1;
    while((!(opt1$kkt2)| is.na(opt1$kkt2)) & step < max.step)
    {
      int1=runif(length(W),-1/maxvalue,1/maxvalue);
      opt1 <- optimx::optimx(int1,neg.likelihood.SAR.MLE.sigma,gr=neg.firstderi.SAR.MLE.sigma, hessian = TRUE,env=env,method="L-BFGS-B",itnmax=5000)

      second<-attr(opt1,"details")[1,]$nhatend;
      step=step+1;
    }
    if(!(opt1$kkt2) & step == max.step)
    {
      opt1[1,1:length(get("W",env))]=0; # no variable would be selected;
      second=neg.secondderi.SAR.MLE.sigma(unlist(opt1[1,1:length(get("W",env))]),env=env);
      converge=FALSE;
    }
  }
  B=expm::sqrtm(second);

  ## The below is finding the penalized solution ###
  #  if(length(get("W",env))==1) B=sqrt(second[1,1])
  if(converge)
  {
    MLE=matrix(unlist(opt1[1,1:length(get("W",env))]),ncol=1)
    Y.lla=B %*% MLE
    X.lla=B
    for(i in 1:ncol(X.lla))
      X.lla[,i]=X.lla[,i]*(MLE[i,1])
    fit4 <- msgps::msgps(X.lla,Y.lla[,1],penalty="enet",alpha=0,intercept=FALSE)

    ## Getting coefficients and tests##
    COEFS=TESTS=NULL;
    vars=solve(second);
    for(i in 1:length(methods))
    {
      if(methods[i]!="MML")
      {
        coefs=coef(fit4)[,methods[i]]*MLE ;
        tests=coefs/sqrt(diag(vars));
      }
      if(methods[i]=="MML")
      {
        tmp=mml.dfgps(fit4$dfgps_result, intercept = fit4$intercept, stand.coef = fit4$stand.coef)
        coefs=tmp$coef*MLE ;
        tests=coefs/sqrt(diag(vars));
      }
      COEFS=rbind(COEFS,matrix(coefs,nrow=1));
      TESTS=rbind(TESTS,matrix(tests,nrow=1));
    }
    rownames(TESTS)=rownames(COEFS)=methods;

    ## Getting Predictions ##
    Wall=data$IBS;
    train.index=data$train.index;
    In=diag(nrow(Wall[[1]]));
    PRED=NULL;
    ASSESS=NULL;
    for(me in 1:length(methods))
    {
      predcoef=COEFS[me,];
      Ctheta=predcoef[1]*Wall[[1]];if(length(Wall)>1){for(i in 2:length(Wall)) Ctheta=Ctheta+predcoef[i]*Wall[[i]]}

      Q=t(In-Ctheta) %*% (In-Ctheta)
      VARS=solve(Q)
      pred2=mean(Y)+VARS[-train.index,train.index] %*% solve(VARS[train.index,train.index]) %*% (Y-mean(Y))
      pred=matrix(pred2,ncol=1)
      colnames(pred)=paste(methods[me],c("pred"),sep="_");
      PRED=cbind(PRED,pred);
      if(assess)
      {
        COR=cor(data$Y[-data$train.index],pred2,use="na.or.complete");
        MSE=mean((data$Y[-data$train.index]-pred2)^2, na.rm = TRUE);
        tmp=matrix(c(COR,MSE),nrow=1);
        colnames(tmp)= c("COR","MSE");
        rownames(tmp)=methods[me];
        ASSESS=rbind(ASSESS,tmp);
      }
    }
    if(assess)
    {
      PRED=cbind("YTrue"=data$Y[-data$train.index],PRED)
    }

    if(tolower(compare)=='rrblup')
    {
      testid=(1:length(data$Y))[-train.index];
      M=data$Geno
      rownames(M) <- 1:nrow(data$Geno)
      A <- rrBLUP::A.mat(M)
      Y1=data$Y
      Y1[testid]=NA
      datablup <- data.frame(y=Y1,gid=1:nrow(data$Geno))
      #predict breeding values
      ans <- rrBLUP::kin.blup(data=datablup,geno="gid",pheno="y",K=A);
      PRED=cbind(PRED,"rrBLUP"=ans$g[testid]+mean(Y1,na.rm=T));

      if(assess)
      {
        CORrrblup <- cor(data$Y[testid],ans$g[testid],use="na.or.complete");
        MSErrblup= mean((data$Y[testid]-(ans$g[testid]+mean(Y1,na.rm=T)))^2, na.rm = TRUE);
        tmp=matrix(c(CORrrblup,MSErrblup),nrow=1);
        colnames(tmp)= colnames(ASSESS)
        rownames(tmp)="rrBLUP";
        ASSESS=rbind(ASSESS,tmp);
      }
    }
    Result=list();
    Result$Pred=PRED;
    Result$Assess=ASSESS;
    #Result$Coefs=COEFS;
    #Result$Tests=TESTS;
    #Result$opt1=opt1;
  }
  if(!converge)
  {
    Result=list();
    Result$Pred=list();
    Result$Assess=list();
    #Result$Coefs=list();
    #Result$Tests=list();
    #Result$opt1=opt1;
    Result$Errors="MLE does not converge! Try new initial values!"
  }
  Result;
}

#' @title Genetic Risk Prediction Using a Spatial Autoregressive Model with Adaptive Lasso
#'
#' @description
#' \code{SARpred} returns the predicted values of the phenotypes.
#' @details
#' This function is used to predict outcomes based on individual's genetic profiles.
#'
#' @param Y A vector of phenotypes. Missing values should be coded as \code{NA}.
#' @param Geno A matrix of genotypes, with each row representing individual and column representing single nucleotide variant.
#' @param TrainID A bool vector with \code{true} indicating the individual is in the training sample.
#' @param genelist A list with each element represents a group.
#' @param Similarity A list with \code{i}-th element measuring the similarity for a particular chuck of genome listed in the \code{genelist[[i]]}.
#' @param SaveSimilarity A bool indicating whether the similarity should be saved for futher use. By default, similarity is not saved.
#' @param compare A string that indicates which method the SARAL compares to. Currently it only supports GBLUP.
#' @param assess A bool. If true, the method will calculate Pearson correlation and mean square error from the testing data. This option is ignored if all the phenotypes of the testing sample is \code{NA} (i.e. \code{sum(!is.na(Y[!TrainID]))==0}).
#' @param methods A string vector that determines which model selection criterion is used to select model for SARAL. By default, it uses Mallows' Cp (Cp), bias corrected AIC (AICc), generalized cross validataion (GCV), BIC, and information theoretic minimum message length (MML).
#' @return A list that contains the predicted values, the pearson correlations and mean square errors (if \code{assess=TRUE}), and error if algorithm does not converge. The list also contains a list of similarity measure (if \code{SaveSimilarity=TRUE}).
#' @examples
#' # This may take 2 hours, don't run if not needed #
#' Y=SARAL::example_SARAL$Y;
#' Geno=SARAL::example_SARAL$Geno;
#' TrainID=SARAL::example_SARAL$TrainID;
#' genelist=SARAL::example_SARAL$Genelist;
#' Result<-SARALpred(Y,Geno,TrainID,genelist,compare='rrblup',assess=TRUE,methods=c("Cp","AICc","GCV","BIC","MML"))
#' @export
SARALpred<-function(Y, Geno, TrainID,genelist=list(),Similarity=NULL,SaveSimilarity=FALSE,YTest=NULL,compare='rrblup',assess=TRUE,methods=c("Cp","AICc","GCV","BIC","MML"))
{
  YTrain=Y[TrainID];
  YTest=Y[!TrainID];
  if(sum(!is.na(YTest))==0 & assess==TRUE)
  {
    warning("Can't assess the prediction performance due to the lack of true values!")
    assess=FALSE;
  }

  ## checking genotypes for both training and testing ##
  if(is.null(colnames(Geno)))
  {
    stop("Genotypes do not have their names!")
  }
  GenoTrain=Geno[TrainID,];
  GenoTest=Geno[!TrainID,];

  ## delete indiviudals in the training set without phenotypes measured ##
  tmp=is.na(YTrain);
  if(sum(tmp)!=0){warning("Individuals without phenotypes in the training set are not used for training the prediction model!")}
  YTrain=YTrain[!tmp];
  GenoTrain=GenoTrain[!tmp,]

  data=list();
  Y=c(YTrain,YTest);
  Geno=rbind(GenoTrain,GenoTest);
  train.index=1:length(YTrain);
  data$Y=Y;
  data$train.index=train.index;
  data$Geno=Geno;
  data$Gene=genelist;
  IBS=list();IBSTrain=list();
  if(length(genelist)==0 & is.null(Similarity)){
    warning("no annotation is provided, and all the SNPs will be treated as if they come from the same gene");
    IBS[[1]]=as.matrix(dist(as.matrix(data$Geno)))
    IBSTrain[[1]]=IBS[[1]][train.index,train.index];
  }
  if(length(genelist)>0 & is.null(Similarity))
  {
    for(i in 1:length(genelist))
    {
      cat("calculating similartiy for the",i,"th gene!","\n");
      geno=data$Geno[,colnames(data$Geno) %in% genelist[[i]]];
      IBS[[i]]=as.matrix(dist(as.matrix(geno)));
      IBSTrain[[i]]=IBS[[i]][train.index,train.index];
    }
  }
  if(!is.null(Similarity))
  {
    if(length(genelist)!=length(Similarity))
    {
      stop("Similarity should be calculated according the genelist. The number of chucks(i.e. the length of the genelist) and the number of similarities are different! Please check!");
    }
    # checking the dimension of similarities
    for(i in 1:length(Similarity))
    {
      if((length(data$Y)!=nrow(Similarity[[i]])) | (length(data$Y)!=ncol(Similarity[[i]])))
      {
        stop("Similarity should be calculated for each pair of individuals, and thus it should be square matrix with the dimension equals to the total sample size! Please check!");
      }
    }
    IBS=Similarity;
    for(i in 1:length(genelist))
    {
      IBSTrain[[i]]=IBS[[i]][train.index,train.index];
    }
  }
  data$IBS=IBS;
  data$train=list();
  data$train$Y=YTrain;
  data$train$Geno=GenoTrain;
  data$train$IBS=IBSTrain;
  cat("Building Risk Prediction Models...");
  Result<-try(SARpredassomain(data,compare=compare,assess=assess,methods=methods),silent=TRUE);
  if(SaveSimilarity) Result$IBS=IBS;
  Result;
}


  predict.mass.g.from.CW.mm = function(cw.mm) {
    mass.g = cw.mm ^ 3.098 *  0.0002665
    return(mass.g)
  }


library('OpenMx')

setwd('~/git/sem_python/tests')
data <- read.csv('HolzingerSwineford1939.csv')

visual <- c('x1', 'x2', 'x3')
textual <- c('x4', 'x5', 'x6')
speed <- c('x7', 'x8', 'x9')
manifest <- c(visual, textual, speed)
latent <- c('visual', 'textual', 'speed')
data <- data[manifest]

model <- mxModel(
    "HolzingerSwineford1939",
    type="RAM",
    manifestVars=manifest,
    latentVars=latent,
    mxData(observed=data, type="raw"),
    mxPath(from=manifest, arrows=2, free=TRUE, values=diag(var(data)) / 2),
    mxPath(from=latent, arrows=2, free=FALSE, values=1),
    mxPath(from=latent, connect='unique.bivariate', arrows=2, free=TRUE, values=1),
    mxPath(from="visual",to=visual, arrows=1, free=TRUE, values=1, labels=c('visual_x1', 'visual_x2', 'visual_x3')),
    mxPath(from="textual",to=textual, arrows=1, free=TRUE, values=1, labels=c('textual_x4', 'textual_x5', 'textual_x6')),
    mxPath(from="speed",to=speed, arrows=1, free=TRUE, values=1, labels=c('speed_x7', 'speed_x8', 'speed_x9')),
    mxPath(from='one', to=manifest, free=FALSE, values=colMeans(data)))

fit <- mxRun(model)

summary(fit)


 F07AQJ Example Program Results

 Solution
    ( 1.0000, 1.0000) ( 2.0000,-3.0000) (-4.0000,-5.0000) ( 0.0000, 6.0000)

 Pivot indices
           3          2          3          4


library(FrF2)
dsg <- FrF2(nruns = 16, nfactors = 10, factor.names = LETTERS[1:10],
            generators = c("ABC", "BCD", "ACD", "ABD", "ABCD", "AB"),
            seed = 123)
summary(dsg)
write.csv(dsg, "dsg.csv")

data <- read.csv("C:/Users/Gary/OneDrive - Stony Brook University/Course/AU21/AMS 582/Project/total22.csv", header = TRUE)
data <- data[, -1]
summary(data)

# cols <- head(colnames(data), -1)
# data[cols] <- lapply(data[cols], factor)
# Don't use factors in lm(). It will give a wrong result for orthogonal coding.
# Encoded as factors or not yield the same result in aov() and anova().

aov1 = aov(y ~ ., data = data)
anova(aov1)
# lm1 = lm(y ~ ., data = data)
# summary(lm1)

MEPlot(aov1, main = NULL)

step(aov1, k = log(nrow(data)))
step(aov1, direction = "backward", k = log(nrow(data)))

aov2 = aov(y ~ C + F + I + C:F + C:I + F:I, data = data)
anova(aov2)

IAPlot(aov2, main = NULL)

aov3 = aov(y ~ C + F + I, data = data)
anova(aov3)

lm3 = lm(y ~ C + F + I, data = data)
summary(lm3)
lm3$coefficients

res = resid(lm3)

plot(fitted(lm3), res, xlab = expression(hat(Y)), ylab = "Residual", pch = 20)
abline(0, 0)

qqnorm(res, main = NULL, pch = 20)
qqline(res, col = 2)

confint(lm3)

pred_data <- expand.grid(C = c(-1, 1), F = c(-1, 1), I = c(-1, 1))
predict(lm3, newdata = pred_data, interval = "confidence")
predict(lm3, newdata = pred_data, interval = "prediction")


infile   = {{i.infile    | quote}}
outfile  = {{o.outfile  | quote}}

{% if args.intype == 'cont' %}

#
#         | Disease | Healthy |
# --------+---------+---------+
#   mut   |   40    |   12    |
# non-mut |   23    |   98    |
# --------+---------+---------+
#
cont.table = read.table(infile, sep = "\t", header = T, row.names = 1, check.names = F)

{% else %}

#
# Contingency table rows: Disease, Healthy
# Contingency table cols: Mut, Non
#
#    | Disease Healthy | Mut  Non  |
# ---+--------+--------+-----+-----+
# S1 |    1   |    0   |  0  |  1  |
# S2 |    0   |    1   |  1  |  0  |
# .. |   ...  |   ...  | ... | ... |
# Sn |    0   |    1   |  0  |  1  |

# NOTE: now it should the transpose of it

ct.cnames = c()
ct.rnames = c()
{% if isinstance(args.ctcols, list) %}
ct.cnames = {{args.ctcols}}
{% elif args.ctcols %}
ct.cnames = {{args.ctcols | lambda x: [y.strip() for y in x.split(',') if y.strip()]}}
{% else %}
trim  = Vectorize(function (x) gsub("^\\s+|\\s+$", "", x))
lines = readLines(infile, n = 2)
for (line in lines) {
	if (!startsWith(line, '# Contingency table ')) next
	if (startsWith(line, '# Contingency table cols:')) {
		ct.cnames = trim(unlist(strsplit(substring(line, 26), ',', fixed = T)))
	}
	else if (startsWith(line, '# Contingency table rows:')) {
		ct.rnames = trim(unlist(strsplit(substring(line, 26), ',', fixed = T)))
	}
}
{% endif %}

raw.data   = read.table(infile, sep = "\t", header = T, row.names = 1, check.names = F)
# generate contingency table
if (length(ct.rnames) == 0 && length(ct.cnames) == 0) {
	stop('No row names and col names specified for contingency table.')
}
if (length(ct.rnames) == 0) {
	ct.rnames = setdiff(colnames(raw.data), ct.cnames)
}
if (length(ct.cnames) == 0) {
	ct.cnames = setdiff(colnames(raw.data), ct.rnames)
}

# transposed cont.table
cont.table = matrix(NA, ncol = length(ct.cnames), nrow = length(ct.rnames))
colnames(cont.table) = ct.cnames
rownames(cont.table) = ct.rnames
# get the number of each contingency cell
for (rname in ct.rnames) {
	for (cname in ct.cnames) {
		tmp1 = raw.data[, rname] == 1
		tmp2 = raw.data[, cname] == 1
		tmp  = tmp1 & tmp2
		cont.table[rname, cname] = length(tmp[tmp])
	}
}
{% endif %}

# further parameters may be introduced, but for now just use defaults
ret = fisher.test(cont.table)
out = data.frame(
	confInt1    = ret$conf.int[1],
	confInt2    = ret$conf.int[2],
	oddsRatio   = ret$estimate,
	pval        = ret$p.value,
	alternative = ret$alternative,
	method      = ret$method
)

#
# Xsquare 1.706667
# df  1
# pval    0.1914184
# method  Pearson's Chi-squared test with Yates' continuity correction
#
write.table(t(out), outfile, col.names = F, row.names = T, sep = "\t", quote = F)


# [NA dan default type](https://academy.dqlab.id/main/livecode/12/44/243)
# Ketik nilai NA
NA
# Tampilkan type dari NA dengan function typeof
typeof(NA)

# [Menggunakan function is.na](https://academy.dqlab.id/main/livecode/12/44/245)
# Buat variable x yang diisi dengan nilai NA
x <- NA
# Pengecekan variable x dengan nilai NA menggunakan operator ==
x == NA
# Pengecekan variable x dengan nilai NA menggunakan function is.na
is.na(x)

# [Variasi NA dan is.na](https://academy.dqlab.id/main/livecode/12/44/248)
typeof(NA_integer_)
typeof(NA_real_)
typeof(NA_complex_)
typeof(NA_character_)
is.na(NA_integer_)
is.na(NA_real_)
is.na(NA_complex_)
is.na(NA_character_)

# [Coercion pada Vector yang mengandung NA](https://academy.dqlab.id/main/livecode/12/44/252)
# Membuat vector bernama isi.vector dengan isi bilangan, dimana salah satunya memiliki missing value
isi.vector <- c(1,2,3,NA,3,1)
# Mengecek keseluruhan tipe data dengan perulangan lapply dan typeof
lapply(isi.vector, typeof)
# Menggunakan is.na untuk mengecek keberadaan missing value dari tiap elemen pada vector
is.na(isi.vector)

# [NULL dan Vector](https://academy.dqlab.id/main/livecode/12/44/254)
# Membuat vector dengan 7 elemen termasuk NA dan NULL
isi.vector <- c(1, 2, 3, NA, 5, NULL, 7)
# Menghitung jumlah elemen dari isi.vector
length(isi.vector)

# [NULL dan List](https://academy.dqlab.id/main/livecode/12/44/259)
#Membuat list dengan 3 elemen termasuk NA dan NULL
isi.list <-  list(1, NULL, 3, NA, 5)
#Menghitung jumlah elemen dari isi.list
length(isi.list)

# [nf untuk mewakili Infinite Number](https://academy.dqlab.id/main/livecode/12/44/261)
# Hitung kalkulasi 5 dibagi dengan 0
5/0
# Hitung kalkulasi -120 dibagi dengan 0
-120/0

# [NaN (Not a Number)](https://academy.dqlab.id/main/livecode/12/44/264)
# Hitung kalkulasi 0 dibagi dengan 0
0/0

# [NaN dari hasil function log()](https://academy.dqlab.id/main/livecode/12/44/266)
# Hitung logaritma dari angka -1000
log(-1000)

# [Fungsi is.nan](https://academy.dqlab.id/main/livecode/12/44/267)
# Buat variable contoh.nan
contoh.nan <- 0/0
# Periksa dengan function is.nan
is.nan(contoh.nan)

# [NaN dan is.na versus NA dan is.nan](https://academy.dqlab.id/main/livecode/12/44/268)
# Masukkan code di bawah ini sesuai permintaan soal
is.na(NaN)
is.nan(NA)

# [Menghitung Jumlah Missing Values dari satu Vector](https://academy.dqlab.id/main/livecode/12/44/270)
# Masukkan code di bawah ini sesuai permintaan soal
isi.vector <- c(1,2,NA,4,5,NaN,6)
sum(is.na(isi.vector) == TRUE)

# [Membuat Factor di R](https://academy.dqlab.id/main/livecode/12/45/287)
# Buatlah factor dengan isi nilai teks "Jan", "Feb", dan "Mar"
factor(c("Jan","Feb","Mar"))

# [Atribut levels dan class pada Factor](https://academy.dqlab.id/main/livecode/12/45/289)
# Variable factor bernama faktor.bulan dengan nilai teks "Jan", "Feb", dan "Mar"
faktor.bulan <- factor(c("Jan","Feb","Mar"))
attributes(faktor.bulan)

# [Function levels dan class pada Factor](https://academy.dqlab.id/main/livecode/12/45/291)
# Variable factor bernama faktor.bulan dengan nilai teks "Jan", "Feb", dan "Mar"
faktor.bulan <- factor(c("Jan","Feb","Mar"))
levels(faktor.bulan)
class(faktor.bulan)

# [Perulangan Nilai pada Factor](https://academy.dqlab.id/main/livecode/12/45/293)
# Buatlah factor dengan teks "Jan", "Feb", "Mar","Jan","Mar", dan "Jan"
factor(c("Jan","Feb","Mar","Jan","Mar","Jan"))

# [Penggunaan as.integer pada Factor](https://academy.dqlab.id/main/livecode/12/45/297)
# Buatlah factor dengan teks "Jan", "Feb", "Mar","Jan","Mar", dan "Jan"
factor.bulan <- factor(c("Jan","Feb","Mar","Jan","Mar","Jan"))
as.integer(factor.bulan)

# [Mengganti "Jan" menjadi "Januari"](https://academy.dqlab.id/main/livecode/12/45/299)
# Buatlah factor dengan teks "Jan", "Feb", "Mar","Jan","Mar", dan "Jan"
factor.bulan <- factor(c("Jan","Feb","Mar","Jan","Mar","Jan"))

# Mengganti levels
levels(factor.bulan)[2] <- "Januari"
levels(factor.bulan)[3] <- "Maret"
factor.bulan

# [Angka sebagai Kategori](https://academy.dqlab.id/main/livecode/12/45/301)
# Buatlah factor bernama factor.umur dengan isi c(12, 35, 24, 12, 35, 37)
factor.umur <- factor(c(12, 35, 24, 12, 35, 37))
# Tampilkan variable factor.umur
factor.umur

# [NA, NaN, NULL pada saat pembentukan Factor](https://academy.dqlab.id/main/livecode/12/45/302)
# Buatlah variable factor.lokasi dengan isi berupa vector
# c("Bandung", "Jakarta", NA, "Jakarta", NaN, "Medan", NULL, NULL, "Bandung")
factor.lokasi <- factor(c("Bandung", "Jakarta", NA, "Jakarta", NaN, "Medan", NULL, NULL, "Bandung"))

# Tampilkan factor.lokasi
factor.lokasi

# [Menghitung panjang Factor dengan length](https://academy.dqlab.id/main/livecode/12/45/303)
# Buatlah variable factor.lokasi dengan isi berupa vector
# c("Bandung", "Jakarta", NA, "Jakarta", NaN, "Medan", NULL, NULL, "Bandung")
factor.lokasi <- factor(c("Bandung", "Jakarta", NA, "Jakarta", NaN, "Medan", NULL, NULL, "Bandung"))
# Tampilkan panjang dari variable factor.lokasi
length(factor.lokasi)
# [Menyusun levels dari awal](https://academy.dqlab.id/main/livecode/12/45/304)
# Variable factor dengan isi vector c("Jan","Feb","Mar","Jan","Mar")
factor(c("Jan","Feb","Mar","Jan","Mar"), levels = c("Jan","Feb","Mar"))

# [Dataset Kependudukan Jakarta](https://academy.dqlab.id/main/livecode/12/46/307)
# [Membaca Dataset CSV](https://academy.dqlab.id/main/livecode/12/46/310)
# Membaca dataset dengan read.csv dan dimasukkan ke variable penduduk.dki
penduduk.dki <- read.csv("https://academy.dqlab.id/dataset/dkikepadatankelurahan2013.csv", sep=",")
penduduk.dki

# [Profile Dataset dengan Function str](https://academy.dqlab.id/main/livecode/12/46/311)
# Membaca dataset dengan read.csv dan dimasukkan ke variable penduduk.dki
penduduk.dki <- read.csv("https://academy.dqlab.id/dataset/dkikepadatankelurahan2013.csv", sep=",")
str(penduduk.dki)
# [Profile Dataset dengan Function summary](https://academy.dqlab.id/main/livecode/12/46/312)
# Membaca dataset dengan read.csv dan dimasukkan ke variable penduduk.dki
penduduk.dki <- read.csv("https://academy.dqlab.id/dataset/dkikepadatankelurahan2013.csv", sep=",")
summary(penduduk.dki)
# [Menggunakan argumen check.names = FALSE](https://academy.dqlab.id/main/livecode/12/46/315)
# Membaca dataset dengan read.csv dan dimasukkan ke variable penduduk.dki
penduduk.dki <- read.csv("https://academy.dqlab.id/dataset/dkikepadatankelurahan2013.csv", sep=",",
                         check.names = FALSE)
str(penduduk.dki)

# [Membaca Tab Separated Value (TSV)](https://academy.dqlab.id/main/livecode/12/46/316)
# Membaca dataset dengan read.csv dan dimasukkan ke variable penduduk.dki
penduduk.dki <- read.csv("https://academy.dqlab.id/dataset/dkikepadatankelurahan2013.tsv", sep="\t")
penduduk.dki

# [Membaca Dataset File Excel dengan read.xlsx](https://academy.dqlab.id/main/livecode/12/46/318)
library(openxlsx)
# Membaca dataset dengan read.xlsx dan dimasukkan ke variable penduduk.dki
penduduk.dki.xlsx <- read.xlsx(xlsxFile="https://academy.dqlab.id/dataset/dkikepadatankelurahan2013.xlsx")
str(penduduk.dki.xlsx)

# [Function names](https://academy.dqlab.id/main/livecode/12/47/324)
# Membaca dataset csv
penduduk.dki.csv <-read.csv("https://academy.dqlab.id/dataset/dkikepadatankelurahan2013.csv", sep=",")
# Menggunakan names untuk variable penduduk.dki.csv
names(penduduk.dki.csv)

# [Merubah Satu Nama Kolom](https://academy.dqlab.id/main/livecode/12/47/325)
# Membaca dataset csv
penduduk.dki.csv <-read.csv("https://academy.dqlab.id/dataset/dkikepadatankelurahan2013.csv", sep=",")
names(penduduk.dki.csv)[1] <- "PERIODE"
names(penduduk.dki.csv)[2] <- "PROPINSI"
names(penduduk.dki.csv)

# [Merubah Sejumlah Nama Kolom](https://academy.dqlab.id/main/livecode/12/47/327)
# Membaca dataset csv
penduduk.dki.csv <-read.csv("https://academy.dqlab.id/dataset/dkikepadatankelurahan2013.csv", sep=",")
names(penduduk.dki.csv)[c(1:2)] <- c("PERIODE", "PROPINSI")
names(penduduk.dki.csv)

# [Membuang Kolom dengan Bantuan Operator %in%](https://academy.dqlab.id/main/livecode/12/47/328)
#Membaca dataset csv
penduduk.dki.csv <-read.csv("https://academy.dqlab.id/dataset/dkikepadatankelurahan2013.csv", sep=",")
#Membuang kolom X, X.1, X.2 s/d X.11
penduduk.dki.csv <- penduduk.dki.csv[,!names(penduduk.dki.csv) %in%
                                       c("X","X.1","X.2","X.3","X.4","X.5","X.6",
                                         "X.7","X.8","X.9","X.10", "X.11")]
names(penduduk.dki.csv)

# [Merubah Tipe Kolom menjadi Factor](https://academy.dqlab.id/main/livecode/12/47/330)
library(openxlsx)
# Membaca dataset dengan read.xlsx dan dimasukkan ke variable penduduk.dki
penduduk.dki.xlsx <- read.xlsx(xlsxFile="https://academy.dqlab.id/dataset/dkikepadatankelurahan2013.xlsx")
penduduk.dki.xlsx$NAMA.PROVINSI <-as.factor(penduduk.dki.xlsx$NAMA.PROVINSI)
str(penduduk.dki.xlsx)

# [Mengambil Kolom Laki.Laki / Perempuan dengan grep](https://academy.dqlab.id/main/livecode/12/47/341)
library(openxlsx)
penduduk.dki.xlsx <- read.xlsx(xlsxFile="https://academy.dqlab.id/dataset/dkikepadatankelurahan2013.xlsx")
# Tampilkan nama-nama kolom yang mengandung kata "perempuan".
pola_nama_perempuan <- grep(pattern="perempuan", x = names(penduduk.dki.xlsx), ignore.case=TRUE)
names(penduduk.dki.xlsx[pola_nama_perempuan])
# Tampilkan nama-nama kolom yang mengandung kata "laki-laki"
pola_nama_laki_laki <- grep(pattern="laki-laki", x = names(penduduk.dki.xlsx), ignore.case=TRUE)
names(penduduk.dki.xlsx[pola_nama_laki_laki])

# [Menambahkan kolom Penjumlahan](https://academy.dqlab.id/main/livecode/12/47/331)
library(openxlsx)
penduduk.dki.xlsx <- read.xlsx(xlsxFile="https://academy.dqlab.id/dataset/dkikepadatankelurahan2013.xlsx")
# Tampilkan nama-nama kolom yang mengandung kata "perempuan".
pola_nama_perempuan <- grep(pattern="perempuan", x = names(penduduk.dki.xlsx), ignore.case=TRUE)
penduduk.dki.xlsx$PEREMPUAN35TAHUNKEATAS  <- rowSums(penduduk.dki.xlsx[pola_nama_perempuan])

# [Normalisasi Data dari Kolom ke Baris](https://academy.dqlab.id/main/livecode/12/47/332)
library(openxlsx)
library(reshape2)
penduduk.dki.xlsx <- read.xlsx(xlsxFile="https://academy.dqlab.id/dataset/dkikepadatankelurahan2013.xlsx")
# Transformasi kolom dataset penduduk.dki.xlsx, disimpan ke variable penduduk.dki.transform
penduduk.dki.transform <- melt(data=penduduk.dki.xlsx,
                               id.vars=c( "NAMA.KECAMATAN", "NAMA.KELURAHAN"),
                               measure.vars = c("35-39.Laki-Laki", "35-39.Perempuan"),
                               variable.name = "DEMOGRAFIK",
                               value.name="JUMLAH")
# Menampilkan variable penduduk.dki.transform
penduduk.dki.transform
# [Split Fields](https://academy.dqlab.id/main/livecode/12/47/334)
library(openxlsx)
library(reshape2)
penduduk.dki.xlsx <- read.xlsx(xlsxFile="https://academy.dqlab.id/dataset/dkikepadatankelurahan2013.xlsx")
penduduk.dki.transform <- melt(data=penduduk.dki.xlsx,
                               id.vars=c( "NAMA.KECAMATAN", "NAMA.KELURAHAN"),
                               measure.vars = c("35-39.Laki-Laki", "35-39.Perempuan"),
                               variable.name = "DEMOGRAFIK",
                               value.name="JUMLAH")
# Memecah isi kolom DEMOGRAFIK menjadi "RENTANG.UMUR" dan "JENIS.KELAMIN"
penduduk.dki.transform[c("RENTANG.UMUR", "JENIS.KELAMIN")] <- colsplit(penduduk.dki.transform$DEMOGRAFIK,"\\.",c("RENTANG.UMUR","JENIS.KELAMIN"))
penduduk.dki.transform$DEMOGRAFIK <- NULL
penduduk.dki.transform

R/Kelas Fundamental/1. Data Preparation in Data Science using R.r


isPrime <- function(n) {
  if (n == 2) return(TRUE)
  if ( (n <= 1) || ( n %% 2 == 0 ) ) return(FALSE)
  for( i in 3:sqrt(n) ) {
    if ( n %% i == 0 ) return(FALSE)
  }
  TRUE
}


# SMAA-1: uncertainty represented by the theoretical probability distributions used to
# generate the "true" observed values. See SMAA-Boot.r for more details.

SMAA1<-function(nI,J,runs,input,dstbn,ta,la)
  {

  x=array(rep(0,nI*J*runs),c(runs,nI,J))
  # Generate array of criterion values (Normal SMAA)
  if (dstbn=="normal"){
    for (i in 1:nI){
      for (j in 1:J){
        x[,i,j]=rnorm(runs,input[i,j,4],input[i,j,5])
      }
    }
  }
  if (dstbn=="skew"){
    for (i in 1:nI){
      for (j in 1:J){
        x[,i,j]=input[i,j,4]+rgamma(runs,shape=input[i,j,5],scale=input[i,j,6])-input[i,j,5]*input[i,j,6]
      }
    }
  }

  # Standardize data by column (criteria) across all generated values
  for (j in 1:J){
    x[,,j]=(x[,,j]-min(x[,,j]))/(max(x[,,j])-min(x[,,j]))
  }

  # Generate matrix of weights (inter-criteria importance)
  w=wts(nC, runs)

  # Compute utilities
  u=array(rep(0,runs*nI*J),c(runs,nI,J))
  for(j in 1:J)
  {
    cutoffs = c(0,ta[j],1)
    values = c(0,la[j],1)
    xt = as.vector(x[,,j])
    xt_pvf = smaa.pvf(xt,cutoffs=cutoffs,values=values,outOfBounds="clip")
    u[,,j] = matrix(xt_pvf,runs,nI)
  }

  # Run SMAA
  b = smaa(u,w)$ra
  b = unclass(b)
  b

}


############
#Calculation of some likelihoods
#
############

gaussian_lik<-function(x,Omega){
  #Omega is precision matrix (inverse of covariance mat)
  d<-length(x)
  -log(2*pi)*d/2 + log( det(Omega) )/2 - crossprod(x,Omega)%*%x /2
}

trw_lik<-function(vert_means,edge_means,vert_coef,edge_coef,part_fn){
  sum( vert_means*vert_coef) + sum( edge_means*edge_coef ) - part_fn
}


library(R2jags)
library(rstan)
rstan_options(auto_write = TRUE)
options(mc.cores = parallel::detectCores())
library(rjags)
library(mcmcplots)
library(truncnorm)
library(Rlab)

## simulate the fake data
set.seed(93)
J <- 40           # number of multiple choice could take
N <- 5            # number of items in the exam
I <- 500          # number of examees

### SDT part

z = array(NA, c(J,N))    # true answer
for (j in 1:J){
    for (n in 1:N){
      this <- rbern(1,0.5)
      if (this > 0.5){
        z[j,n] <- 1
      }else{
        z[j,n] <- -1
      }
    }
}

lambda = array(NA, c(I,J))
y = array(NA, c(I,J,N))
c = array(NA, c(J,N))
delta = array(NA, c(I,J,N))
p = array(NA, c(I,J,N))

d = rlnorm(J,0,0.5)
theta = rnorm(I,0,1)
b = rnorm(J,0,2)

for (i in 1:I){
  for (j in 1:J){
    lambda[i,j] <- 1 / (1 + exp(b[j] -  theta[i]))
    for (n in 1:N){
      c[j,n] <- rnorm(n=1,(1/2)*d[j]*z[j,n],1)
      p[i,j,n] <- lambda[i,j] * (1 -pnorm(c[j,n] - d[j] * z[j,n],0,1)) + (1 - lambda[i,j]) * (1- pnorm(c[j,n],0,1))
      y[i,j,n] <- rbern(1,p[i,j,n])
    }
  }
}

obs_3pl= matrix(NA, nrow = I, ncol = J)

for (i in 1:I){
  for (j in 1:J){
    obs_3pl[i,j] =  as.numeric(all(as.numeric(z[j,] == 1) == y[i,j,]))
  }
}
PL.dat <- list("I"=I,"J"=J,"obs_3pl"=obs_3pl)
PL.fit <- stan("3PL.stan", data=PL.dat)
saveRDS(PL.fit,'PL_fit.rds')


library(igraph)

a_matrix_file <- read.csv("matrix.csv", header = FALSE, encoding = "UTF-8")

a_matrix <- as.matrix(a_matrix_file)

entity_id_file <- read.csv("entity_id.csv", header = FALSE, encoding = "UTF-8")

entity_id <- as.matrix(entity_id_file)

label <- entity_id[, 2]

g <- graph.adjacency(a_matrix, mode = "undirected", weighted = T)

plot(g, vertex.label = label)

print(degree(g, mode = "total"))
print(closeness(g))
print(betweenness(g, directed = FALSE))

degree_cent <- degree(g, mode = "total")
closeness_cent <- closeness(g)
betweenness_cent <- betweenness(g, directed = FALSE)

E(g)$weight

igraph.plot(g)


 F02WGJ Example Program Results

  Singular Value    Residual
    0.00830           2.7E-19
    0.01223           5.9E-18
    0.02381           1.2E-17
    0.11274           7.8E-17


#!/usr/bin/env RScript

# $ brew tap homebrew/science
# $ brew install R

NUM_TRIALS <- 10000
PRIOR_LOWER_MAX <- 100

# Runs a single trial where an envelope is chosen.  If the chosen envelope has
# a value < cutoff, the function will switch envelopes, otherwise it will keep
# the envelope it has chosen. Returns the value of the envelope it ultimately
# selects.
singleTrial <- function(cutoff, rand1, rand2) {
  lower_value <- rand1 * PRIOR_LOWER_MAX
  higher_value <- 2 * lower_value
  if (rand2 < 0.5) {
    if (lower_value >= cutoff) lower_value else higher_value
  } else {
    if (higher_value >= cutoff) higher_value else lower_value
  }
}

# Runs many trials at a given cutoff to approximate the expected value.
multiTrial <- function(cutoff) {
  total <- 0
  # runif performance is pretty bad, this saves 7 seconds of runtime.
  rand_vals <- runif(2 * (NUM_TRIALS + 1))
  for (i in 1:NUM_TRIALS) {
    rand1 <- rand_vals[2 * i - 1]
    rand2 <- rand_vals[2 * i]
    # Inlining singleTrial would save another ~1.3 seconds.
    total <- total + singleTrial(cutoff, rand1, rand2)
  }
  total / NUM_TRIALS
}

for (cutoff in 0:(2 * PRIOR_LOWER_MAX)) {
  print(sprintf("cutoff=%s, expected_value=%f", cutoff, multiTrial(cutoff)))
}


 ZPTTRF Example Program Results

 Details of factorization

  The diagonal elements of D
   16.0000   9.0000   1.0000   4.0000

  Subdiagonal elements of the Cholesky factor L
    1.0000   1.0000   2.0000  -1.0000   1.0000  -4.0000


# Behaviour of median in function of x observations.

round_timestamp <- function(ts, scalefactor.sec = 3600*12) {
  as.POSIXct(round(as.numeric(ts)/scalefactor.sec) * scalefactor.sec, origin = '1970-01-01', tz = 'UTC')
}

read.baro <- function(logger.name) {
  df <- gwloggeR.data::read(logger.name)$df
  if (nrow(df) == 0L) return(df)
  df <- df[!is.na(TIMESTAMP_UTC), ]
  df <- df[!is.na(PRESSURE_VALUE), ]
  df <- df[!duplicated(TIMESTAMP_UTC), ]
  df <- df[, .('PRESSURE_VALUE' = mean(PRESSURE_VALUE)),
           by = .('TIMESTAMP_UTC' = round_timestamp(TIMESTAMP_UTC))]
  df[, 'FILE' := basename(logger.name)]
  df[, 'N' := .N]
  data.table::setkey(df, TIMESTAMP_UTC)
  structure(df, 'logger.name' = logger.name)
}

df.knmi <- read.baro('KNMI_20200312_hourly')

boot.sample <- function(n.obs) {
  N <- nrow(df.knmi)
  n.omit.first <- sample.int(n.obs, 1L)
  n.omit.last <- (N - n.omit.first) %% n.obs
  i.omit <- c(1L:n.omit.first, if (n.omit.last == 0L) NULL else (N-n.omit.last+1L):N)
  i.groups <- rep(1L:((N - n.omit.first - n.omit.last) %/% n.obs), each = n.obs)
  df.knmi[-i.omit, .(VAL = median(PRESSURE_VALUE)), by = i.groups]$VAL
}

boot <- function(n.obs, n.samples.min = 1000L) {
  n.samples <- 0L
  samples <- list()
  repeat({
    if (sum(vapply(samples, length, 1L)) >= n.samples.min) break()
    samples[[length(samples) + 1L]] <- boot.sample(n.obs = n.obs)
  })
  unlist(samples)
}

hist(boot(100), breaks = 100)

n.obs <- seq(from = 10, to = 3500, by = 10)
parallel::setDefaultCluster(parallel::makeCluster(spec = 7L))
parallel::clusterExport(varlist = c('boot.sample', 'df.knmi'))
results <- parallel::clusterApplyLB(x = n.obs, fun = boot)
parallel::stopCluster(cl = parallel::getDefaultCluster())

stats <- data.table::data.table(n.obs = n.obs)
stats[, sd := vapply(results, sd, 1)]
stats

ggplot2::ggplot(data = stats, mapping = ggplot2::aes(x = n.obs, y = sd)) +
  ggplot2::geom_line() +
  ggplot2::theme_light() +
  ggplot2::ylab('Standard deviation of the median pressure (chH2O)') +
  ggplot2::xlab('Number of observations (12h interval)') +
  ggplot2::ggtitle('KNMI Westdorpe bootstrapped sample from 2010-2020')


library(ggplot2)

CrimeData <- read.csv("../../data/CrimeData.csv")

str(CrimeData)

head(CrimeData)

head(CrimeData$Dispatch_Date_Time)

CrimeData$DateTime <- as.POSIXct(CrimeData$Dispatch_Date_Time, format="%Y-%m-%d %H:%M:%S", tz="EST")

?POSIXct

head(CrimeData$DateTime)

CrimeData$Date <- as.Date(CrimeData$DateTime, tz="EST")
str(CrimeData)

by_date <- aggregate(CrimeData$Date, by = list(Date = CrimeData$Date), FUN = length)

?aggregate

str(by_date)

colnames(by_date) <- c("Date", "Total")

str(by_date)

head(by_date)

ggplot(by_date, aes(Date, Total, color=Total)) + geom_line()

CrimeData$Hour <- strftime(CrimeData$DateTime, format = '%H', tz='EST')

str(CrimeData)

by_hour <- aggregate(CrimeData$Hour, by = list(Hour = CrimeData$Hour), FUN=length)

str(by_hour)

colnames(by_hour) <- c("Hour", "Total")

str(by_hour)

by_hour

by_hour$Hour <- as.integer(by_hour$Hour)

str(by_hour)

ggplot(by_hour, aes(Hour, Total)) +
  geom_line(colour="Red") +
  ggtitle("Crimes By Hour") +
  xlab("Hour of the Day") +
  ylab("Total Crimes")

CrimeData$Month <- strftime(CrimeData$DateTime, format = '%m', tz='EST')

str(CrimeData)

by_month <- aggregate(CrimeData$Month, by = list(Month = CrimeData$Month), FUN=length)

str(by_month)

colnames(by_month) <- c("Month", "Total")

str(by_month)

by_month$Month <- as.integer(by_month$Month)

str(by_month)

by_month

ggplot(by_month, aes(Month, Total)) +
  geom_bar(fill="Maroon", stat="identity")+
  ggtitle("Crimes By Month") +
  xlab("Month of the Day") +
  ylab("Total Crimes")

by_category <- aggregate(CrimeData$Text_General_Code,
                         by = list(Typec = CrimeData$Text_General_Code),
                         FUN = length)

# rename columns
colnames(by_category) <- c("Type", "Total")

by_category

by_category_sorted <- by_category[order(by_category$Total, decreasing=T),]

by_category_sorted

top10crimes <- by_category_sorted[1:10,]

top10crimes

ggplot(top10crimes, aes(x=reorder(Type,Total), y=Total)) +
  geom_bar(aes(fill=Type), stat="identity") +
  coord_flip()

by_hq <- aggregate(CrimeData$Dc_Dist, by = list(HQ = CrimeData$Dc_Dist), FUN=length)

#rename columns
colnames(by_hq) <- c("HQ", "Total")

ggplot(by_hq, aes(reorder(HQ, -Total), Total)) +
  geom_bar(color = "gray", stat="identity")


# 4. faza: Analiza podatkov

#Leto 1935 je naše izhodišče, zato ga postavimo kot leto 0

pdf("slike/populacija.pdf")

leto <- demographics$Year - 1900
pop <- demographics$Population.x1000 / 1000

plot(leto, pop, xlab = "Leto", ylab = "Populacija x 1000000")

legend(40, 300, c("Linerana", "Kvadratna"), lty=c(1,1), col = c("blue","red"))

#Npišemo funkcijo za linearno rast

linearna <- lm(pop ~ leto)
abline(linearna, col="blue")

#Preverimo če je populacija kvadratna funkcija

kvadratna <- lm(pop ~ I(leto^2) + leto)
curve(predict(kvadratna, data.frame(leto=x)), add = TRUE, col = "red")

#Loess model za primerjavo (model loess uporablja lokalno prilagajanje)

loess <- loess(pop ~ leto)

#Pogledamo ostanke pri modelih. Tisti, ki ima manjši ostanek je bolj natančen

vsota.kvadratov <- sapply(list(linearna, kvadratna, loess), function(x) sum(x$residuals^2))

dev.off()

#Narisali bomo napoved za rast prebivalstva do leta 2030 po modelu za modeala linear in kvadratna

pdf("slike/napoved.pdf")

plot(demographics$Year, pop, xlim = c(1935, 2050), ylim = c(120, 450),
     xlab = "Leto", ylab = "Populacija (v mil)",
     main = "Predvidena rast prebivalstva po različnih modelih")
abline(h = 400,col = "black", lwd = 1.5, lty = 1)

#Presečišča izračunamo na roko

points(2040, 400,  col = "black", pch = 21)
points(2048, 400,  col = "black", pch = 21)

#V presečiščih potegnemo navpične črte

abline(v=2040, col = "magenta", lty = 1)
abline(v=2048, col = "magenta", lty = 1)

napoved <- function(x,model){predict(model, data.frame(leto=x-1900))}

curve(napoved(x, linearna), add= TRUE, lwd = 1.5, col = "blue")
curve(napoved(x, kvadratna), add = TRUE, lwd = 1.5, col = "red")

#Narišemo še legendo
legend(1932, 380, c("Linerana (lm(pop ~ leto))", "Kvadratna (lm(pop ~ I(leto^2) + leto))",
                    "400 miljonov prebivalcev"),
       lty=c(1,1), col = c("blue","red", "black"))

dev.off()

# Narisali bomo še graf ZDA po gostoti prebivalstva, saj je to ena izmed stvari, ki me je
# na začetku zanimala

#Paketi za delo z zemljevidi
library(sp)
library(maptools)
library(rgeos)
gpclibPermit()

pdf("slike/gostota.pdf")

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

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

m <- match(states$STATE_NAME, rownames(ZDA))

gostota <- ZDA[,8]
max.gostota <- max(gostota)
min.gostota <- min(gostota)
norm.gostota <- (gostota - min.gostota)/(max.gostota - min.gostota)
#Uporabimo koren zaradi bolj enakomerne porazdelitve
barve <- rgb(1, 0, 0, sqrt(norm.gostota))

k <- 8 # število stopenj
stopnje <- seq(min.gostota, max.gostota, (max.gostota - min.gostota)/(k-1))
norm.stopnje <- (stopnje - min.gostota)/(max.gostota - min.gostota)
barve.stopnje <- rgb(1, 0, 0, sqrt(norm.stopnje))

plot(states, col = barve[m])
title( main = expression(paste("Gostota prebivalstva podana v ", 1/mi^2)))

legend("bottomleft", legend = round(stopnje), fill = barve.stopnje, cex = 0.7)

dev.off()

#k-means clustering
#Iz tabelele ZDA poberemo vse imenske spremenljivke (Abbr, Capital, Largest.City, Size)

data <- ZDA
data$Abbr <- NULL
data$Capital<- NULL
data$Largest.City <- NULL
data$Size<- NULL

data1 <- scale(data)

#Narišemo nekaj grafov

rezultati <- kmeans(data1, centers = 4)
center <- rezultati$centers
skupina <- rezultati$cluster
barve <- c("red", "green", "blue", "yellow")

pdf("slike/clustering_1.pdf")

plot(data[,"Population.2013"]/1000000,data[,"Pop.Density"], col = barve[skupina],
     xlab = "Populacija v milijonih", ylab = "Gostota prebivalstva",
     main = "Razvrščanje - Odvisnost gostote od populacije")

dev.off()

pdf("slike/clustering_2.pdf")

plot(data[,"Total.area.in.mi2"]/1000, data[,"Population.2013"]/1000000, col = barve[skupina],
     xlab = "Velikost x 1000 (mi^2)", ylab = "Populacija v milijonih",
     main = "Razvrščanje - Odvisnot populacije od velikosti države")

dev.off()

pdf("slike/clustering_3.pdf")

plot(data[,"Total.area.in.mi2"]/1000, data[,"Pop.Density"], col = barve[skupina],
     xlab = "Velikost x 1000 (mi^2)", ylab = "Gostota prebivalstva",
     main = "Razvrščanje - Odvisnost gostote od velikosti države")

dev.off()

#Narišemo še zemljevid in ga pobarvamo po skupinah

pdf("slike/zemljevid_grupe.pdf")

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

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

plot(states, col = barve[skupina])
title( main = "Države razdeljene po skupinah glede na k-means razvrščanje")

dev.off()


#' Conclude position of linkage group on plot area
#'
#' @param dfori Original data frame
#' @param chromosomes Character vector of requested linkage groups
#' @param xsize X size of plot area
#' @param ysize Y size of plot area
#' @param telsize Value of telomere size (Default = 40)
#' @return Modified data frame extended by positional values
#' @export
placements <- function(dfori, chromosomes, xsize, ysize, telsize){
  # prepare data frame of calculated locations
  targets_chr <- data.frame(targets = as.character(chromosomes),
                            leftborder = as.numeric(linkage.group.position(xsize, length(chromosomes))),
                            rightborder = as.numeric(linkage.group.position(xsize, length(chromosomes)) + telsize),
                            size = round(as.numeric(tapply(dfori$cM, dfori$chr, max)[chromosomes]),1))

  targets_chr$height <- round((900 * (targets_chr$size / max(targets_chr$size))), 1)

  # prepare main table of requested chromosomes
  df <- merge(dfori, targets_chr, by.x = "chr", by.y = "targets")
  df <- df[df$chr %in% targets_chr$targets, ]

  # calculate marker position
  df$startabsolute <- round((ysize - (df$height * (df$cM / df$size))), 1)
  df$endabsolute <- round((ysize - (df$height * ((df$cM + 0.01) / df$size))), 1)

  # format conversion NEEDED to display correct linkage groups afterwards
  df$chr <- as.character(df$chr)
  df$marker <- as.character(df$marker)

  return(df)
}


########################################################################
#### Perform preliminary analysis---------------------------------------
########################################################################

# calculate b-w % difference in death, exposure, and risk rates
bw_percent_diff_all <- calculate_percent_diff(age_stand_all)
bw_percent_diff_pveh <- calculate_percent_diff(age_stand_pveh)
bw_percent_diff_ped <- calculate_percent_diff(age_stand_ped)

# plots b-w absolute values
plot_exposure(exp.all)
plot_exposure(exp.pveh)
plot_exposure(exp.ped)

# plots risk and exposure effects
risk_exp_plot <- ggplot(data = decomp_combined %>%
                          dplyr::select(-total_effect, -c(risk_percent_mile:exp_percent_mile)) %>%
                          melt(id.vars = c("gender", "age.cat", "type")),
                        aes(x = age.cat, y = value, fill = variable)) +
  geom_bar(stat="identity", position=position_dodge()) +
  facet_grid(type ~ gender, scales = "free") +
  theme(legend.position="bottom") + geom_hline(yintercept=0) +
  theme_bw() +
  scale_fill_discrete(name=" ",
                      breaks=c("risk_effect_mile", "exp_effect_mile"),
                      labels=c("Risk Effect", "Exposure Effect"))+
  scale_x_discrete("Age Categories",
                   labels = c("5-14", "15-24", "25-44", "45-64", "65-84")) +
  theme(axis.text.x = element_text(angle = -90, hjust = 0, vjust = 0)) +
  theme(axis.text=element_text(size=10))+
  theme(axis.title.x = element_blank()) +   # Remove x-axis label
  theme(axis.title.y = element_blank()) +   # Remove x-axis label
  theme(axis.text.x = element_text(angle = -90, hjust = 0, vjust = 0)) +
  theme(legend.text = element_text(size = 10)) +
  theme(strip.text = element_text(size=10)) +
  theme(legend.position="bottom")

risk_exp_plot


 DGESVJ Example Program Results

 Singular values
     9.9966  3.6831  1.3569  0.5000
 Left singular vectors
          1       2       3       4
 1  -0.2774  0.6003 -0.1277  0.1323
 2  -0.2020  0.0301  0.2805  0.7034
 3  -0.2918 -0.3348  0.6453  0.1906
 4   0.0938  0.3699  0.6781 -0.5399
 5   0.4213 -0.5266  0.0413 -0.0575
 6  -0.7816 -0.3353 -0.1645 -0.3957

 Right singular vectors
          1       2       3       4
 1  -0.1921  0.8030  0.0041 -0.5642
 2   0.8794  0.3926 -0.0752  0.2587
 3  -0.2140  0.2980  0.7827  0.5027
 4   0.3795 -0.3351  0.6178 -0.6017

 Error estimate for the singular values
        2.2E-15

 Error estimates for left singular vectors
        3.5E-16    9.5E-16    2.6E-15    4.4E-15

 Error estimates for right singular vectors
        3.5E-16    9.5E-16    2.6E-15    2.6E-15


library('lavaan')

setwd('~/git/sem_python/tests')
# data <- read.csv('PoliticalDemocracy_missing.csv')
data <- read.csv('PoliticalDemocracy.csv')

model <- '
  # measurement model
    ind60 =~ x1 + x2 + x3
    dem60 =~ y1 + y2 + y3 + y4
    dem65 =~ y5 + y6 + y7 + y8
  # regressions
    dem60 ~ ind60
    dem65 ~ ind60 + dem60
 # residual correlations
    y1 ~~ y5
    y2 ~~ y4 + y6
    y3 ~~ y7
    y4 ~~ y8
    y6 ~~ y8
'

fit <- sem(model, data = data, auto.fix.first = FALSE, std.lv = TRUE, missing = 'fiml')
summary(fit)


#' Slackwater/suspension method to calculate paleoslope from preserved sediments
#'
#' \code{lynds_three} calculates the slope of an ancient river, provided you know the flow depth, the grain size of the bed material, and the maximum grain size of suspended sediment. Implemented from Lynds et al. (2014)
#' @param ws_mode Allows you to choose one of two different methods for calculating the settling velocity of the bedload particles. 'simple' ignores the Corey Shape Factor and the Powers Index. See documentation for \code{settle} for more information. For now, this feature is disabled.
#' @param Dbed The median grain size of bedload sediments in meters.
#' @param Dsusp The maximum grain size of suspended sediments in meters.
#' @param H The paleoflow depth in meters.
#' @param rhos The density of the sediment in kg/m^3
#' @param rhof The density of the fluid in kg/m^3
#' @return Returns a list with two elements: \code{S}, the dimensionless slope, and \code{F}, the ratio of total boundary shear stress to skin friction shear stress.
#' @export

#	Third method to reconstruct paleoslope from Lynds et al 2014
#	Eric Barefoot
#	Nov 2017

#	define needed variables and data types

#source(paste0(fd,'settle.r'))

lynds_three = function(Dbed, Dsusp, H, rhos = 2650, rhof = 1000, ws_mode = 'simple') {

	#	D is the D50b or median bedload grainsize
	#	H is Hbf or the bankfull flow depth

	#	constants
	#	NOTE: a number of these relationships depend on older dune scaling relationships. may be worthwhile upgrading to something as recommended by venditti 2017

	g = 9.8
	Cd = 0.21			#	drag coefficient for separated flow
	k = 0.407			#	von Karman constant
	hd = 0.3 * H		#	height of dunes. *** may also be able to calculate a priori from leclair?? ***
	lam = hd / 0.063 	#	for ratio of hd to lambda
	zo = 0.056 * 2 * Dbed	#	boundary layer thickness

	wsmax = settle('simple', Dsusp, constants = list(g = g, rhos = rhos, rhof = rhof, nuu = 1.004e-6))$ws

	F = 1 + (Cd / (2 * k^2)) * (hd / lam) * (log(hd / zo) - 1)^2

	#	final slope equation

	S = (F * wsmax^2) / (g * H)

	return(list(S = S, F = F))

}


library(optimx)
library(tidyverse)
library(lme4)
dat <- read.csv("binomials_data.csv")

lrs <- function(x,y) {
  if(x>y)
    return("LEFT")
  if(x<y)
    return("RIGHT")
   return("EQUAL")
}

dat$size_top <- with(dat, mapply(lrs,SIZE_A_TOP,SIZE_B_TOP))
dat$size_center <- with(dat, mapply(lrs,SIZE_A_CENTER,SIZE_B_CENTER))
dat$size_bottom <- with(dat, mapply(lrs,SIZE_A_BOTTOM,SIZE_B_BOTTOM))
dat$size_chosen <- with(dat,sapply(1:nrow(dat),function(i) switch(as.character(CHOICE[i]),
                                                       TOP=size_top[i],
                                                       CENTER=size_center[i],
                                                       BOTTOM=size_bottom[i])))
dat$size_constraint <- with(dat,mapply(function(x,y) ifelse((x==1 & y=="LEFT") | (x==2 & y=="RIGHT"),"SATISFIED",
                                                            ifelse((x==2 & y=="LEFT") | (x==1 & y=="RIGHT"),"VIOLATED",
                                                                   ifelse(y=="EQUAL","EQUAL_SIZE_CHOSEN",
                                                                          NA))),
                                       WORD_ORDER,size_chosen))
m.size <- glmer(size_constraint=="SATISFIED" ~ 1 + (1|SUB) + (1|ITEM),subset(dat,! (is.na(size_constraint) | size_constraint=="EQUAL_SIZE_CHOSEN")),family="binomial")
m0.size <- glmer(size_constraint=="SATISFIED" ~ 0 + (1|SUB) + (1|ITEM),subset(dat,! (is.na(size_constraint) | size_constraint=="EQUAL_SIZE_CHOSEN")),family="binomial")
summary(m.size)
anova(m0.size,m.size)
dat$offset_term <- logit(1/3)

m.equalsize <- glmer(size_constraint=="EQUAL_SIZE_CHOSEN" ~ offset(offset_term) + (1|SUB) + (1|ITEM), subset(dat, ! is.na(size_constraint)),family="binomial")
summary(m.equalsize)
m0.equalsize <- glmer(size_constraint=="EQUAL_SIZE_CHOSEN" ~ 0 + offset(offset_term) + (1|SUB) + (1|ITEM), subset(dat, ! is.na(size_constraint)),family="binomial")

dat$order_chosen <-with(dat,sapply(1:nrow(dat),function(i) switch(as.character(CHOICE[i]),
                                                                         TOP=ORDER_TOP[i],
                                                                         CENTER=ORDER_CENTER[i],
                                                                         BOTTOM=ORDER_BOTTOM[i])))
dat$order_constraint <- with(dat,ifelse(WORD_ORDER==0,NA,WORD_ORDER==order_chosen))
m.order <- glmer(order_constraint ~ 1 + (1|SUB) + (1|ITEM),subset(dat,!is.na(order_constraint)),family="binomial",control = glmerControl(
  optimizer ='optimx', optCtrl=list(method='L-BFGS-B')))
m0.order <- glmer(order_constraint ~ 0 + (1|SUB) + (1|ITEM),subset(dat,!is.na(order_constraint)),family="binomial",control = glmerControl(
  optimizer ='optimx', optCtrl=list(method='L-BFGS-B')))
summary(m.order)
anova(m0.order,m.order)

# removing item random effect as it had zero variance
m.a.order <- glmer(order_constraint ~ 1 + (1|SUB),subset(dat,!is.na(order_constraint)),family="binomial",control = glmerControl(
  optimizer ='optimx', optCtrl=list(method='L-BFGS-B')))
m0.a.order <- glmer(order_constraint ~ 0 + (1|SUB),subset(dat,!is.na(order_constraint)),family="binomial",control = glmerControl(
  optimizer ='optimx', optCtrl=list(method='L-BFGS-B')))
summary(m.a.order)
anova(m0.a.order,m.a.order)


# Anne S. Warlaumont

# Test to see if there are statistically significant differences between Realistic and Abstract simulations at generation 100

# If you run with the following command, a file containing the output will be saved to the directory containing this script:
# R CMD BATCH AnalyzeFitness.r

rm(list=ls())

library(lme4)
library(lmerTest)

# Change the directory as needed:
#simdata = read.csv('~/Downloads/MultipleRunsData.csv',header=T)
simdata = read.csv('/Volumes/Storage/NeuralNetVocalControlEvolutionRuns/multRunsSummary_Ready/MultipleRunsData.csv',header=T)

simdata$medProFitnessScaled = scale(simdata$medProFitness)
simdata$medPerFitnessScaled = scale(simdata$medPerFitness)
simdata$generationScaled = scale(simdata$generation)

t.test(subset(subset(simdata,useVocalTract==0),generation==100)$medProFitness,subset(subset(simdata,useVocalTract==1),generation==100)$medProFitness)
t.test(subset(subset(simdata,useVocalTract==0),generation==100)$medPerFitness,subset(subset(simdata,useVocalTract==1),generation==100)$medPerFitness)

t.test(subset(subset(simdata,useVocalTract==0),generation==500)$medProFitness,subset(subset(simdata,useVocalTract==1),generation==500)$medProFitness)
t.test(subset(subset(simdata,useVocalTract==0),generation==500)$medPerFitness,subset(subset(simdata,useVocalTract==1),generation==500)$medPerFitness)

aggdataPro = aggregate(medProFitness~runfolder+useVocalTract,subset(simdata,generation>25 & generation < 150),mean)
t.test(subset(aggdataPro,useVocalTract==0)$medProFitness,subset(aggdataPro,useVocalTract==1)$medProFitness)

aggdataPer = aggregate(medPerFitness~runfolder+useVocalTract,subset(simdata,generation>25 & generation < 150),mean)
t.test(subset(aggdataPer,useVocalTract==0)$medPerFitness,subset(aggdataPer,useVocalTract==1)$medPerFitness)

proFitModel = lmer(medProFitnessScaled~(1|runfolder)+useVocalTract+generationScaled+useVocalTract*generationScaled,data=subset(simdata,generation<=100 & generation > 50))
summary(proFitModel)
quartz(); qqnorm(resid(proFitModel))

perFitModel = lmer(medPerFitnessScaled~(1|runfolder)+useVocalTract+generationScaled+useVocalTract*generationScaled,data=subset(simdata,generation<=100 & generation > 50))
summary(perFitModel)
quartz(); qqnorm(resid(perFitModel))

var.test(subset(subset(simdata,useVocalTract==0),generation==100)$medProFitness,subset(subset(simdata,useVocalTract==1),generation==100)$medProFitness)
var.test(subset(subset(simdata,useVocalTract==0),generation==100)$medPerFitness,subset(subset(simdata,useVocalTract==1),generation==100)$medPerFitness)

var.test(subset(subset(simdata,useVocalTract==0),generation==500)$medProFitness,subset(subset(simdata,useVocalTract==1),generation==500)$medProFitness)
var.test(subset(subset(simdata,useVocalTract==0),generation==500)$medPerFitness,subset(subset(simdata,useVocalTract==1),generation==500)$medPerFitness)


## Hankui wrote it on Aug 27 2016

# source("getKappa.r");
# a is predicted
# b is ground truth

getKappa <- function (a, b)
{
	# a <- iris.rf2$predicted[is.element.index]
	# b <- yftrain[is.element.index]
	samplesn <- length(a);
	classes <- union(unique(a),unique(b));
	lengthc <- length(classes);
	kappaa <- 0;
	if (lengthc<=1 || length(unique(b))<=1) {kappaa <- 1;return(NA);}
	conf1 <- vector(mode="double", length=lengthc);
	conf2 <- vector(mode="double", length=lengthc);
	for (i in 1:lengthc) {
		conf1[i] <- sum(a==classes[i])
		conf2[i] <- sum(b==classes[i])
	}
	qqq <- conf1/samplesn;
	ppp <- conf2/samplesn;
	expAccuracy <- sum(ppp*qqq);
	OA <- sum(a==b)/samplesn;
	kappaa = (OA - expAccuracy)/(1 - expAccuracy)
	return(kappaa);
}


#@author: Romeo Kienzler
#This file is copyright protected - do not redistribute

library(scatterplot3d)
library(ggplot2)
library(stats)
library(h2o)
localH2O = h2o.init(nthreads = -1)
simuURL="https://pmqsimulator-romeokienzler-1155.mybluemix.net/data"
df = read.csv(simuURL,sep = ";",header = FALSE)
dim(df)
colnames(df) = c("t","x","y","z")
scatterplot3d(df$x,df$y,df$z, type = "l")

ggplot() +
  geom_line(data = df, aes(x = t, y = x),colour = "red") +
  geom_line(data = df, aes(x = t, y = y), colour = "blue") +
  geom_line(data = df, aes(x = t, y = z), colour = "green")

xfft = Im(fft(df$x))
yfft = Im(fft(df$y))
zfft = Im(fft(df$z))
ggplot() +
  geom_line(data = df, aes(x = t, y = xfft),colour = "red")  +
  geom_line(data = df, aes(x = t, y = yfft), colour = "blue") +
  geom_line(data = df, aes(x = t, y = zfft), colour = "green")

df = read.csv(simuURL,sep = ";",header = FALSE)
dim(df)
colnames(df) = c("t","x","y","z")

xfft = Im(fft(df$x))
yfft = Im(fft(df$y))
zfft = Im(fft(df$z))
ggplot() +
  geom_line(data = df, aes(x = t, y = xfft),colour = "red")  +
  geom_line(data = df, aes(x = t, y = yfft), colour = "blue") +
  geom_line(data = df, aes(x = t, y = zfft), colour = "green")

tsDataPrev=NULL
while (TRUE) {
  print("reading data...")
  df = read.csv(simuURL,sep = ";",header = FALSE)
  print("done")
  colnames(df) = c("t","x","y","z")
  xfft = Im(fft(df$x))
  yfft = Im(fft(df$y))
  zfft = Im(fft(df$z))
  tsData = as.h2o(t(data.frame(xfft,yfft,zfft)))
  NN_model = h2o.deeplearning(
    x = 1:3,
    training_frame = tsData,
    hidden = c(3000, 2, 3000),
    epochs = 300,
    activation = 'Tanh',
    autoencoder = TRUE
  )

  anomalyrates = as.data.frame(h2o.anomaly(NN_model,tsData))
  print(sum(anomalyrates))
  flush.console()
  if (!is.null(tsDataPrev)) {
    anomalyrates = as.data.frame(h2o.anomaly(NN_model,tsDataPrev))
    print(sum(anomalyrates))
    flush.console()
  }
  tsDataPrev=tsData;
}


# drwhy.ai
# https://pbiecek.github.io/ema

library(DALEX)
library(ranger)

# Stwórzmy dwa modele, liniowy oraz las losowy
apartments_lm_model <- lm(m2.price ~ ., data = apartments)
predicted_mi2_lm <- predict(apartments_lm_model, apartmentsTest)

sqrt(mean((predicted_mi2_lm - apartmentsTest$m2.price)^2))

apartments_rf_model <- ranger(m2.price ~ ., data = apartments)
predicted_mi2_rf <- predict(apartments_rf_model, apartmentsTest)$predictions
sqrt(mean((predicted_mi2_rf - apartmentsTest$m2.price)^2))

explainer_lm <- explain(apartments_lm_model,
                        data = apartmentsTest,
                        y = apartmentsTest$m2.price,
                        label = "Linear Model")

explainer_rf <- explain(apartments_rf_model,
                        data = apartmentsTest,
                        y = apartmentsTest$m2.price,
                        label = "RF model")

(mp_lm <- model_performance(explainer_lm))
(mp_rf <- model_performance(explainer_rf))
plot(mp_lm)
plot(mp_lm, geom = "boxplot")
plot(mp_lm, mp_rf)
plot(mp_lm, mp_rf, geom = "boxplot")

md_lm <- model_diagnostics(explainer_lm)
md_rf <- model_diagnostics(explainer_rf)

plot(md_lm, md_rf, variable = "y", yvariable = "y_hat")

library(ggplot2)

plot(md_lm, md_rf, variable = "y", yvariable = "y_hat") +
  facet_wrap(~label) +
  geom_abline(slope = 1)

# Variable Importance
vi_lm <- variable_importance(explainer_lm, loss_function = loss_root_mean_square)
plot(vi_lm)

vi_rf <- variable_importance(explainer_rf, loss_function = loss_root_mean_square)
plot(vi_rf)

plot(vi_lm, vi_rf)

# Czy zadziała dla klasyfikacji? Tak

titanic_glm_model <- glm(survived ~., data = titanic_imputed, family = "binomial")
titanic_rf_model <- ranger(as.factor(survived)~., data = titanic_imputed, classification = TRUE, probability = TRUE)

explainer_classif_lm <- explain(titanic_glm_model, data = titanic_imputed[,-8], y = titanic_imputed$survived)
explainer_classif_rf <- explain(titanic_rf_model, data = titanic_imputed[,-8], y = titanic_imputed$survived)

vi_class_lm <- variable_importance(explainer_classif_lm, loss_function = loss_one_minus_auc)
plot(vi_class_lm)

vi_class_rf <- variable_importance(explainer_classif_rf, loss_function = loss_one_minus_auc)
plot(vi_class_rf)

plot(vi_class_lm, vi_class_rf)

# Partial Dependence Plots

pdp_regr_rf  <- variable_effect(explainer_rf, variable =  "construction.year", type = "partial_dependency")
pdp_regr_lm  <- variable_effect(explainer_lm, variable =  "construction.year", type = "partial_dependency")
plot(pdp_regr_rf, pdp_regr_lm)

pdp_classif_rf  <- variable_effect(explainer_classif_lm, variable =  "fare", type = "partial_dependency")
pdp_classif_lm  <- variable_effect(explainer_classif_rf, variable =  "fare", type = "partial_dependency")
plot(pdp_classif_rf, pdp_classif_lm)

pdp_regr_rf_factor  <- variable_effect(explainer_rf, variable =  "district",
                                       type = "partial_dependency", variable_type = "categorical")
pdp_regr_lm_factor  <- variable_effect(explainer_lm, variable =  "district",
                                       type = "partial_dependency", variable_type = "categorical")
plot(pdp_regr_rf_factor, pdp_regr_lm_factor)

# iBreakDown

bd_lm <- predict_parts(explainer_lm, new_observation = apartments[5,])
bd_rf <- predict_parts(explainer_rf, new_observation = apartments[1,])
plot(bd_lm)
plot(bd_rf)

library(patchwork)

plot(bd_lm) | plot(bd_rf)

bd_titanic <- predict_parts(explainer_classif_rf, new_observation = titanic_imputed[1,])
plot(bd_titanic)

# modelStudio

library(modelStudio)
new_observations <- titanic_imputed[1:4,]
rownames(new_observations) <- c("Lucas", "James", "Thomas", "Nancy")
modelStudio(explainer_classif_rf, new_observations)

#modelOriented/modelStudio

# DALEXtra

library(DALEXtra)

library("mlr")
library("DALEXtra")
task <- mlr::makeRegrTask(
  id = "R",
  data = apartments,
  target = "m2.price"
)
learner_lm <- mlr::makeLearner(
  "regr.lm"
)
model_lm <- mlr::train(learner_lm, task)
explainer_lm <- explain_mlr(model_lm, apartmentsTest, apartmentsTest$m2.price, label = "LM")

?explain_mlr3
?explain_mlr
?explain_scikitlearn

learner_rf <- mlr::makeLearner(
  "regr.randomForest"
)
model_rf <- mlr::train(learner_rf, task)
explainer_rf <- explain_mlr(model_rf, apartmentsTest, apartmentsTest$m2.price, label = "RF")

plot_data <- funnel_measure(explainer_lm, explainer_rf,
                            nbins = 5, measure_function = DALEX::loss_root_mean_square)
plot(plot_data)


##
## Standardized Precipitation Index helper functions
##
fit.gamma <- function (v)
{
    ## Strategy: Try gamma fit with fitdistr, if doesn't work, use bordi
    ##           et al, 2001, anal geofisica
    alpha <- beta <- q <- gamma <- NA
    if (sum(!is.na(v)) >= 20) { ## Require at least 20 usable values
        v <- v[!is.na(v)]
        q <- sum(v == 0)/length(v)
        v <- v[v > 0]
        m <- mean(v)

        suppressPackageStartupMessages(require("MASS"))
        gamma <- try(fitdistr(v, "gamma"), silent = TRUE)
        {
            if (length(gamma) == 5) {
                alpha <- gamma$est[1]
                beta <- gamma$est[2]
            }
            else {
                A <- log(m) - sum(log(v))/length(v)
                alpha <- 1/(4 * A) * (1 + sqrt(1 + 4 * A/3))
                beta <- m/alpha
            }
        }
    }
    ## Return
    list(alpha = alpha, beta = beta, q = q, l = (gamma))
}

transform.to.spi <- function (v, gamma)
{
    ## Cummulative function accounting for 0 precip
    Hv <- gamma$q + (1 - gamma$q) * pgamma(v, gamma$alpha, gamma$beta)
    qnorm(Hv)
}

calc.spi <- function (my.p, ref.inds, timescale)
{
    info_output("<<<<<<<< Entering calc.spi()", verbosity, 8)
    {
        if (length(my.p) > 1) {
            ## Aggregate my.p over timescale
            agg.p <- my.p
            if (timescale > 1) {
                for (j in timescale:ncol(my.p)) {
                    agg.p[, j] <- apply(my.p[, (j - timescale + 1):j], 1, sum)
                }
                agg.p[, 1:(timescale - 1)] <- NA
            }
            ## Fit gamma and spi per month
            gammas <- list()
            spis <- matrix(nrow = nrow(agg.p), ncol = ncol(agg.p))
            for (m in 1:12) {
                ## Gamma
                gamma.inds <- seq(m + ref.inds[1] - 1, max(ref.inds), by = 12)
                ## Remove the gamma.inds for which the agg.p-columns are set to NA
                gamma.inds <- setdiff(gamma.inds, 1:(timescale - 1))
                gammas[[m]] <- apply(agg.p[, gamma.inds], 1, fit.gamma)

                ## SPI
                spi.inds <- seq(m, ncol(agg.p), by = 12)
                spis[, spi.inds] <- t(sapply(1:nrow(agg.p), function(i) transform.to.spi(agg.p[i,
                  spi.inds], gammas[[m]][[i]])))

                info_output(paste0("m=", m, " of 12"), verbosity, 9)
            }
            info_output(">>>>>>>> Leaving calc.spi()", verbosity, 8)
            spis
        } else {
            info_output(">>>>>>>> Leaving calc.spi()", verbosity, 8)
            NA
       }
    }
}

##
## Function: Read data and calculate spi
##

## Input: Filename of monthly precip netcdf file, first and last time
##        step of this file yyyy/mm/dd, timescale in months, first and
##        last year of the reference period.

generate.spi <- function (fullpath_filename, filename,
        start_year, end_year, timescale,
        begin.ref.year, end.ref.year,
        model_idx)
{
    info_output(filename, verbosity, 1)
    info_output(fullpath_filename, verbosity, 1)
    info_output("<<<<<<<< Entering generate.spi()", verbosity, 6)
    suppressPackageStartupMessages(require(ncdf4))
    suppressPackageStartupMessages(require(chron))
    precip.nc <- nc_open(fullpath_filename)

    ## Try to figure out lon/lat/time naming
    pot.lon.names <- c("lon", "Lon", "Longitude", "longitude", "X", "x")
    pot.lat.names <- c("lat", "Lat", "Latitude", "latitude", "Y", "y")
    pot.time.names <- c("time", "Time", "date", "Date", "T", "t")

    lon.name <- pot.lon.names[pot.lon.names %in% names(precip.nc$dim)]
    lat.name <- pot.lat.names[pot.lat.names %in% names(precip.nc$dim)]
    time.name <- pot.time.names[pot.lat.names %in% names(precip.nc$dim)]

    if (!(length(lon.name) > 0 && length(lat.name) > 0 && length(time.name) > 0
        && is.character(lon.name) > 0 && is.character(lat.name) > 0
        && is.character(time.name) > 0)) {

        stop(paste("fatal:Cannot guess dim names of", fullpath_filename))
    }

    lon <- ncvar_get(precip.nc, lon.name)
    lat <- ncvar_get(precip.nc, lat.name)
    time <- ncvar_get(precip.nc, time.name)

    ## Define time axis
    start_date <- as.Date(paste0(start_year, "-01-15"))
    end_date <- as.Date(paste0(end_year, "-12-15"))
    dates <- seq(start_date, end_date, by = "1 month")
    if (length(dates) != length(time))
        stop("fatal:Specified begin/end date and length of time dimension mismatch.")

    ## Check if reference period is covered by data
    if (begin.ref.year < start_year || end.ref.year > end_year)
        stop("fatal:Specified reference period outside temporal coverage.")

    ## Reference period
    begin.ref <- as.Date(paste(begin.ref.year, "01/01", sep = "/"))
    end.ref <- as.Date(paste(end.ref.year, "12/31", sep = "/"))
    ref.inds <- which(findInterval(dates, c(begin.ref, end.ref)) == 1)

    ## Calculate spi
    my.p <- matrix(ncvar_get(precip.nc), ncol = length(dates))

    curr_model_str <- models_name[model_idx]
    output_str <- paste0("Now calculating spi for model ", curr_model_str)
    info_output(output_str, verbosity, 1)

    spi <- calc.spi(my.p, ref.inds, timescale)
    spi[!is.finite(spi)] <- NA

    ## Output to ncdf
    description <- "_values_wrt_"
    out.filename <- processed_spi_info(timescale, description,
                                       begin.ref.year, end.ref.year,
                                       filename)
    x <- ncdim_def("Lon", "degreesE", lon)
    y <- ncdim_def("Lat", "degreesN", lat)
    t <- ncdim_def("Time", "days since 1970-01-01", as.numeric(dates), unlim = TRUE)

    spi.var <- ncvar_def("SPI", "unitless", list(x, y, t), 1e+30)
    info_output(out.filename, verbosity, 1)
    out.filename <- file.path(climo_dir, out.filename)
    info_output(out.filename, verbosity, 1)
    ncid <- nc_create(out.filename, list(spi.var))
    ncvar_put(ncid, spi.var, spi, start = c(1, 1, 1), count = c(-1, -1, -1))
    nc_close(ncid)

    info_output(">>>>>>>> Leaving generate.spi()", verbosity, 6)
    ## Return spi, dates, lon, lat
    list(spi = spi, dates = dates, lon = lon, lat = lat, timescale = timescale,
        begin.ref.year = begin.ref.year, end.ref.year = end.ref.year,
        filename = filename)
}

##
## Function: Evaluate spi
##

## Input: A list like the one returned by generate.spi()

evaluate.spi <- function (spi.info)
{
    info_output("<<<<<<<< Entering evaluate.spi()", verbosity, 6)
    if (!is.list(spi.info) || length(spi.info) != 8)
        stop("fatal:Wrong input to evaluate spi.")

    spi <- spi.info$spi
    dates <- spi.info$dates
    lon <- spi.info$lon
    lat <- spi.info$lat
    timescale <- spi.info$timescale
    begin.ref.year <- spi.info$begin.ref.year
    end.ref.year <- spi.info$end.ref.year
    filename <- spi.info$filename

    if (length(lon) * length(lat) != nrow(spi)
            || begin.ref.year >= end.ref.year
            || length(dates) != ncol(spi)) {
        stop("fatal:Wrong input to evaluate spi.")
    }

    suppressPackageStartupMessages(require(ncdf4))
    suppressPackageStartupMessages(require(chron))

    ## Determine seasonal and annual time series
    my.seasons <- quarters(dates)
    my.seasons <- c(my.seasons[2:length(my.seasons)], NA)
    my.years <- years(dates)
    season.inds <- list(ann = 1:length(dates),
        mam = which(my.seasons == "Q2"), jja = which(my.seasons == "Q3"),
        son = which(my.seasons == "Q4"), djf = which(my.seasons == "Q1"))

    ## Find grid points with not just missing values
    good.gps <- which(is.finite(apply(spi, 1, max, na.rm = TRUE)))

    ## Aggregate
    spi.agg <- list()
    for (s in names(season.inds)) {
        info_output(paste("aggregating for", s), verbosity, 4)
        spi.agg[[s]] <- matrix(nrow = nrow(spi), ncol = length(levels(my.years)))
        ii <- season.inds[[s]]
        for (i in good.gps) {
            if (s != "djf")
                spi.agg[[s]][i, ] <- tapply(spi[i, ii], my.years[ii],
                  mean)
            else {
                djf.years <- c((my.years[2:(length(my.years))]),
                  NA)
                spi.agg[[s]][i, ] <- tapply(spi[i, ii], djf.years[ii],
                  mean)
            }
        }
    }

    ## Calculate  linear trends for annual and seasonal time scale
    trends <- p.values <- list()
    for (s in names(season.inds)) {
        info_output(paste("calculating linear trends for", s), verbosity, 4)
        trends[[s]] <- p.values[[s]] <- rep(NA, nrow(spi.agg[[s]]))

        ## Find grid points with at least 70% coverage
        good.gps <- which(apply(!is.na(spi.agg[[s]]), 1, sum)/ncol(spi.agg[[s]]) > 0.7)
        for (i in good.gps) {
            lm <- lm(spi.agg[[s]][i, ] ~ as.numeric(levels(my.years)))
            ## Decadal change
            trends[[s]][i] <- coef(lm)[[2]] * 10
            ## p.value
            p.values[[s]][i] <- summary(lm)$coef[, "Pr(>|t|)"][[2]]
        }
    }

    ## Save to ncdf

    ## Create "time steps", indicating the beginning of the season and
    ## using last year as year.
    last.year <- max(levels(my.years))
    out.time <- c(paste(last.year,"01-01",sep="-"),
                  paste(last.year,"03-01",sep="-"),paste(last.year,"06-01",sep="-"),
                  paste(last.year,"09-01",sep="-"),paste(last.year,"12-01",sep="-"))
    out.time <- as.Date(out.time)

    description <- "_trends-n-pvals_wrt_"
    out.filename <- processed_spi_info(timescale, description,
                                       begin.ref.year, end.ref.year,
                                       filename)

    x <- ncdim_def("Lon", "degreesE", lon)
    y <- ncdim_def("Lat", "degreesN", lat)
    t <- ncdim_def("Time", "days since 1970-01-01", as.numeric(out.time), unlim = TRUE)

    trend.out <- as.vector(unlist(trends))
    pval.out <- as.vector(unlist(p.values))

    trend.var <- ncvar_def("Decadal_Trend", "unitless", list(x, y, t), 1e+30)
    pval.var <- ncvar_def("p_Value", "unitless", list(x, y, t), 1e+30)
    out.filename <- file.path(climo_dir, out.filename)
    ncid <- nc_create(out.filename, list(trend.var, pval.var))

    ncvar_put(ncid, trend.var, trend.out, start = c(1, 1, 1), count = c(-1, -1, -1))
    ncvar_put(ncid, pval.var, pval.out, start = c(1, 1, 1), count = c(-1, -1, -1))
    nc_close(ncid)

    info_output(">>>>>>>> Leaving evaluate.spi()", verbosity, 6)
    ## Return -- nothing
}

##
## Function: Define filenamed for SPI processed data
##
processed_spi_info <- function(timescale,
                               description,
                               begin.ref.year,
                               end.ref.year,
                               filename) {
    info_output("<<<<<<<< Entering processed_spi_info()", verbosity, 8)
    info_output(">>>>>>>> Leaving processed_spi_info()", verbosity, 8)
    return_processed_info <- paste("SPI", timescale, description, begin.ref.year,
        "-", end.ref.year, "_", filename, sep = "")
}


portfolio.summary <- function(twri, value, twrib) {

    ## Minimum input
    ## Given:     twri    = incremental TWR (time weighted return) for holdings
    ##            value   = xts object with value of each holding over time
    ##            twrib   = twri for benchmark
    ##            twri.ef = twri for efficient frontier

    ## Output:    twrc.ytd = twrc (cumulative TWR) for year to date
    ##            twrcb    = twrc for benchmark

    ## create dataframe for output
    df <- data.frame(description = c(names(twri), 'portfolio', names(twrib)))

    ## convert any NA to 0
    twri[is.na(twri)] <- 0

    ## check that twri and value have the same dates (needed for portfolio weighting over time)
    if (!identical(zoo::index(value), zoo::index(twri))) {
        ## problem with input value and twri not being consistent
        cat('\n\n#######################################################\n')
        cat(    '#    WARNING: VALUE AND TWRI DATES NOT CONSISTENT      \n')
        cat(    '#######################################################\n\n')
        return()
    }

    ## determine portfolio value and weights for holdings
    value0      <- value / (twri + 1)                       # values if back out holding twri
    value.port  <- apply(value , 1, sum)                    # sum rows
    value0.port <- apply(value0, 1, sum)                    # sum rows
    twri.port   <- value.port / value0.port - 1
    weight      <- as.numeric( value[nrow(value),] / sum(value[nrow(value),]) )

    ## add weights and values to df
    weight <- c(weight, 1, rep(NA, ncol(twrib)))
    value  <- c(as.numeric(value[nrow(value),]),
                sum(value[nrow(value),]),
                rep(NA, ncol(twrib)))
    df$value  <- value
    df$weight <- weight

    ## turn twri.port back into xts object
    portfolio <- xts::as.xts( zoo::as.zoo( as.matrix(twri.port), zoo::index(twri)))
    colnames(portfolio) <- 'portfolio'

    ## combine into single xts object
    twriall <- cbind(twri, portfolio, twrib)

    ## set date ranges to evaluate
    dates <- zoo::index(twri)
    ##               YTD       1 year       3 years      5 years
    date.range <- c('1 year', '12 months', '36 months', '60 months')

    i <- 0
    twrc <- NA
    df.names <- names(df)
    ## add twrc values for various date ranges to df
    for (date.eval in date.range) {

        i <- i + 1

        ## extract timeframe for date.eval
        twri.eval <- xts::last(twriall, date.eval)

        ## identify corresponding xtsrange
        from <- zoo::index(twri.eval)[1]
        to   <- zoo::index(twri.eval)[nrow(twri.eval)]
        xtsrange <- paste(from, '/', to, sep='')

        ## above xtsrange words easiest for TWRC
        ## but need the time zero from date to later convert to twrc.annual
        from0.index <- grep(from, dates) - 1
        from0 <- zoo::index(twri)[from0.index]
        xtsrange0 <- paste(from0, '/', to, sep='')

        ## calculate twrc
        twrc  <- cumprod(twri.eval+1) - 1
        twrc.l <- t( xts::last(twrc) )    # last row as a column matrix

        ## annualize twrc
        ## average annual return
        ## days.held <- as.numeric( sum( diff(zoo::index(twri.eval)) ) )
        days.held <- as.numeric( sum( diff(zoo::index(twri[xtsrange0])) ) )
        if (days.held > 366) {
            twrc.ann  <- (1 + twrc.l)^(365.25 / days.held) - 1
        } else {
            twrc.ann  <- twrc.l
        }

        df <- cbind(df, twrc.ann)

    }

    row.names(df) <- seq(1, nrow(df))
    names(df) <- c(df.names, 'TWRC YTD', 'TWRC 1-yr', 'TWRC 3-yr', 'TWRC 5-yr')
    df.cols <- ncol(df)
    perf <- df
    perf$date <- zoo::index(twri.eval)[nrow(twri.eval)]

    ## change twrc, std, twrc.ann, and std.ann to character and apply % sign
    df$value  <- scales::dollar(df$value)
    df$weight <- round(df$weight, 2)
    df[4:df.cols] <- sapply(df[4:df.cols], function(x) scales::percent(x, accuracy=0.01))
    cat('\nEvaluation as of', as.character(zoo::index(twri.eval)[nrow(twri.eval)]), '\n')
    cat(  'TWRC for YTD is not annualized. Longer durations are annualized.\n')
    print(df)

    return(perf)

}


# Performing arithmetic on matrix elements

# all_wars_matrix is available in your workspace
all_wars_matrix

# Estimate the visitors
visitors <- all_wars_matrix / 5

# Print the estimate to the console
visitors

# all_wars_matrix and ticket_prices_matrix are available in your workspace
all_wars_matrix
ticket_prices_matrix

# Estimated number of visitors
visitors <- all_wars_matrix / ticket_prices_matrix

# US visitors - first column from matrix
us_visitors <- visitors[,1]

# Average number of US visitors
mean(us_visitors)


## From John.Stickley@bch.nhs.uk

require(rms)

test_data <-
structure(
    list(group = structure( c(1L, 2L, 2L, 1L, 2L, 1L, 2L,
        1L, 2L, 2L, 1L, 2L, 1L, 2L, 1L, 1L, 1L, 1L, 2L, 1L, 1L, 1L, 1L,
        1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 1L, 2L, 1L, 2L, 2L, 1L,
        2L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 1L, 2L, 1L),
    .Label = c("a", "b"), class = "factor"),
    survival = c(17.46772065, 98.92209528,78.29864249, 9.822413669, 79.55050186, 82.36595474, 1.42766417,
                71.48805748, 61.33571345, 84.62631825, 93.03022837, 44.04354499,
                81.06711649, 26.19891261, 68.64477557, 52.2160246, 17.780942,
                4.515968877, 95.46066172, 73.63010059, 40.13833451, 20.39467002,
                50.80529216, 70.23087236, 23.89309088, 53.86527662, 3.422234859,
                35.30675488, 50.07307746, 4.68602929, 86.04636345, 72.98976535,
                33.18048902, 37.94566436, 83.17678398, 16.95356411, 80.5844794,
                8.599290846, 46.06581857, 1.644574571, 34.81582745, 49.96017595,
                11.74200883, 60.07697075, 80.40946019, 55.00705828, 17.75483404,
                98.69523629, 68.15668013, 4.959304343),
    outcome = c(0L, 0L, 0L,0L, 0L, 0L, 1L, 0L, 1L, 0L, 1L, 0L, 0L, 0L, 0L, 1L, 0L, 1L, 0L,
                    1L, 0L, 1L, 0L, 1L, 0L, 1L, 1L, 0L, 0L, 0L, 1L, 1L, 0L, 1L, 0L,
                    1L, 1L, 1L, 1L, 1L, 1L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 1L)),
    .Names = c("group", "survival", "outcome"), class = "data.frame",
    row.names = c(NA, -50L))

table(test_data$group)
s <- npsurv(Surv(survival, outcome) ~ group, data = test_data)
s$n.risk[c(1, s$strata['group=a'] + 1)]

survplot(s, conf='none', lwd=2, lty=c(1,1,1), n.risk=TRUE, time.inc=5,
         label.curves=FALSE, cex.lab=1.75)


library(igraph)
library(igraphdata)

#lists data
data(package = "igraphdata")

#matrix
data(kite)
plot(kite)
kite[]

#edgelist
data(Koenigsberg)
plot(Koenigsberg)
get.edgelist(Koenigsberg)

#sociogram
data(karate)
plot(karate)


context("IDW")
library("NSmetabolism")

test_that("IDW-river works on single and multiple input values", {
	q <- c(1, 5, 6, 10, 16)
	dist <- matrix(c(
		 0, NA, -1, NA, -2,
		NA,  0, -1, NA, -2,
		 1,  1,  0, NA, -1,
		NA, NA, NA,  0, -1,
		 2,  2,  1,  1,  0), byrow=TRUE, nrow=length(q))
	vals <- c(1, 2, NA, NA, 3)

	# set up the lists
	idwVals <- nbQ <- idwDist <- list()
	for(i in 1:length(q)) {
		j <- !is.na(vals) & !is.na(dist[i,])
		idwVals[[i]] <- vals[j]
		nbQ[[i]] <- q[j]
		idwDist[[i]] <- dist[i,j]
	}

	expect_error(newVals <- idw_river(idwVals, idwDist, nbQ, q), regex = NA)
	j <- is.na(vals)
	expect_identical(newVals[!j], vals[!j])
	i <- c(1,2,5)
	j <- 3
	qr <- q[i] / q[j]
	qr[3] <- 1/qr[3]
	wt <- qr * 1/(dist[j,i]^2)
	wt <- wt/sum(wt)
	expect_equal(newVals[3], sum(vals[i] * wt))
	expect_equal(newVals[4], vals[5]) # 5 is the only neighbor, so they are equal
})

test_that("Regular IDW", {
	vals = matrix(c(5,10, 1, 3, 2, 4), nrow=2)
	dmat = c(1, 10)
	expect_error(idw_matrix(vals, dmat[1]), regex="length")
	expect_error(idw_matrix(vals, dmat), regex=NA)
})


# read the file
x1= read.delim("E:/denboer2009-expr.txt")
rownames(x1)= x1[,1]
x3 = x1[,-1]
x= as.data.frame(t(x3))

# read the lables
y= read.delim("E:/denboer2009-pheno (2).txt")
rownames(y)= y[,1]
y= y[,-1]

# add lables to data as a column
x$sample = substr(y[,5],1,190)

#anova
#A function for culculating ANOVA
AOV= function(Gene){
  Q= x[,c(Gene , "sample")]
  colnames(Q)[1] = "Gene"
  anova(aov( Gene~sample, Q))[1,5]
}

# Apply ANOVA to all genes
Genes = colnames(x)
Genes = Genes[-length(Genes)]  # remove last lable coolumn
sapply_anova = (sapply(Genes , AOV))
sapply_anova_df = data.frame(Genes,sapply_anova)

#sort results by p value
sort_by_pvalue_anova = sapply_anova_df[order(sapply_anova_df$sapply_anova),]

Gene recommendation system by ANOVA/ANOVA.r


.b = import('../base')
.st = import('../stats')
#.spf = import('../stats/process_formula')

#' Plots a given data.frame as a linear fit with optional subsets
#'
#' @param df        data.frame holding at least the columns specified by x, y, and label
#' @param x         Column to be plotted on the horizontal axis
#' @param y         Column to be plotted on the vertical axis
#' @param label     Column of label to be used for each sample; indicates subsets
#' @param drop      Whether to drop unused factor levels in `label`
#' @param pt.size   Size of the points indicating the samples
#' @param fit.size  Width of the line(s) used for indicating the fit
linear_fit = function(formula, subsets=NULL, data=parent.frame(),
                      drop=TRUE, pt.size=4, fit.size=5) {

#TODO: formula length=3, [[1]]="~"
#TODO: if subsets is single char, take column in data
    x = as.matrix(base::eval(formula[[3]], envir=data))
    y = as.matrix(base::eval(formula[[2]], envir=data))

    # allow either subsets or multiple columns in one matrix
    if (((ncol(x) > 1) + (ncol(y) > 1) + (!is.null(subsets))) > 1)
        stop("can only take multiple cols in one matrix or subsets")
    if (ncol(x) > 1) {
        subsets = c(sapply(colnames(x), function(i) rep(i, nrow(x))))
        y = rep(y, ncol(x))
        x = c(x)
    } else if (ncol(y) > 1) {
        subsets = c(sapply(colnames(y), function(i) rep(i, nrow(y))))
        x = rep(x, ncol(y))
        y = c(y)
    } else
        subsets = rep(1, nrow(x))

    result = st$lm(y ~ x, subsets=subsets) %>%
        filter(term == "x" & p.value < 0.05)

    df = data.frame(x=x, y=y, subsets=subsets) %>%
        filter(subsets %in% result$subset)
#    print(result$p.value)

#    if (length(unique(df[[label]])) > 1)
#        df = df[df[[label]] %in% result$subset[result$p.value<0.05],]

#    rsq = round(result$main*1000) / 10
#    if (drop)
#        df$tissue = sapply(as.character(df$tissue), function(t) paste(t, "-", rsq[t], "%"))
#    if (!drop && !is.na(only) && length(only)==1)
#        tit = paste(only, "-", rsq[only], "%")
#    else
#        tit = paste("Correlation between", pathway, "activity and", drug, "response")

    ggplot(df, aes(x=x, y=y, colour=subsets)) +
        geom_smooth(aes(fill=subsets), size=fit.size, method=stats::lm, se=F, na.rm=T, alpha=0.1) +
        geom_point(aes(fill=subsets), pch=21, size=pt.size, colour="black", alpha=1, na.rm=T) +
        scale_fill_discrete(drop=drop) +
        scale_colour_discrete(drop=drop)
}