library(ncdf4)

#years of interest:
start <- 1990
end <- 2017

setwd("G:/DaymetUS/California")
#list of ALL weather layers
lst <- dir("G:/DaymetUS/California", pattern='.tif$', full.names=T)

#sublist of weather coefficients
Mlst <- lst[grep("_m", lst)] #M = moisture;
Clst <- lst[grep("_c", lst)] #C = temperature;

Mlst_sub <- grep(paste(as.character(seq(start,end)), collapse="|"), Mlst, value=TRUE)  #use only the raster files matching the years of interest
Clst_sub <- grep(paste(as.character(seq(start,end)), collapse="|"), Clst, value=TRUE)  #use only the raster files matching the years of interest

Mstack <- stack(Mlst_sub)
Cstack <- stack(Clst_sub)

#----------------
# Make dimensions
#----------------
xvals <- xFromCol(Mstack, col=1:ncol(Mstack))
yvals <- yFromRow(Mstack, row=1:nrow(Mstack))

nx <- length(xvals)
ny <- length(yvals)
nt <- length(Mstack@layers) #MUST be same as Cstack@layers

xdim <- dim.def.ncdf( 'X', 'meters_easting', xvals )
ydim <- dim.def.ncdf( 'Y', 'meters_northing', yvals )
tdim <- dim.def.ncdf('time', units='weeks since 2000-01-01', nt, unlim=TRUE)

#---------
# Make var
#---------
mv <- -9999     # missing value
var_mcf <- var.def.ncdf( "Mcoef", "units", list(xdim,ydim,tdim), mv )
var_ccf <- var.def.ncdf( "Ccoef", "units", list(xdim,ydim,tdim), mv )

#---------------------
# Make new output file
#---------------------
output_fname <- paste('weatherCoeff_', start, '_', end, '.nc', sep='')
ncid_new <- create.ncdf( output_fname, list(var_mcf, var_ccf))

#-------------------------------
# Put data into the file
#-------------------------------
for(i in 1:nt) {
	data2d_m <- as.matrix(Mstack[[i]])   #one should take the transpose of the matrix if you want to match Mstack[[i]] at this stage
	data2d_c <- as.matrix(Cstack[[i]])
	put.var.ncdf(ncid_new, var_mcf, data2d_m, start=c(1,1,i), count=c(-1,-1,1))
	put.var.ncdf(ncid_new, var_ccf, data2d_c, start=c(1,1,i), count=c(-1,-1,1))
}
#--------------------------
# Close our new output file
#--------------------------
close.ncdf( ncid_new )

#check if things are right
nc <- open.ncdf(output_fname)
#Var <- get.var.ncdf(nc, "var_name_here")  #get variable of interest into an R array
Var <- get.var.ncdf(nc, "Mcoef")
#plot original raster and netcdf slice...they must match!!
plot(Mstack[[10]])
plot(raster(Var[,,10]))  #if you used the transpose in the LOOP above, then remember to also use t(Var[,,]) here!
close.ncdf(nc)


#' Machine_float
#'
#' Numerical characteristics of the machine for floats. Contains analogues of
#' much of the double precision details of \code{.Machine}.
#'
#' Values are taken directly from \code{float.h}.
#'
#' @format
#' A list containing:
#' \itemize{
#'   \item \code{float.eps} epsilon
#'   \item \code{float.xmin} smallest non-zero float
#'   \item \code{float.xmax} largest non-inf float
#'   \item \code{float.base} radix
#'   \item \code{float.digits} the number of bits for the sign+significand
#'   \item \code{float.exponent} number of bits for the exponent
#'   \item \code{float.min.exp} "largest negative" (smallest) integer for the
#'       exponent that generates a normalized floating-point number
#'   \item \code{float.max.exp} largest integer for the
#'       exponent that generates a normalized floating-point number
#' }
#'
#' @docType data
"Machine_float"

#' NaNf
#'
#' 32-bit float \code{NaN}
#'
#' @format
#' A 32-bit float.
#'
#' @docType data
"NaNf"

#' NA_float_
#'
#' 32-bit float \code{NA}
#'
#' @format
#' A 32-bit float.
#'
#' @docType data
"NA_float_" # initialized in zzz.r


cat(sapply(strsplit(readLines(tail(commandArgs(), n=1)), ","), function(s) {
  m <- as.integer(s[1])
  l <- 0
  for (i in 1:length(s)) {
    a <- as.integer(s[i])
    if (a + l > m) {
      m <- a + l
    }
    if (a + l > 0) {
      l <- l + a
    } else {
      l <- 0
    }
  }
  m
}), sep="\n")


 DBDSVDX Example Program Results

  3 singular values of B in the range [  0.000,  4.000]:
         3.0006        1.9960        0.9998


LISP Interpreter Run

[[[[ Omega in the limit from below! ]]]]

define (count-halt prefix bits-left-to-extend)
    if = bits-left-to-extend 0
    if = success car try t 'eval read-exp prefix
       1 0
    + (count-halt append prefix '(0) - bits-left-to-extend 1)
      (count-halt append prefix '(1) - bits-left-to-extend 1)

define      count-halt
value       (lambda (prefix bits-left-to-extend) (if (= bits-l
            eft-to-extend 0) (if (= success (car (try t (' (ev
            al (read-exp))) prefix))) 1 0) (+ (count-halt (app
            end prefix (' (0))) (- bits-left-to-extend 1)) (co
            unt-halt (append prefix (' (1))) (- bits-left-to-e
            xtend 1)))))

define (omega t) cons (count-halt nil t)
                 cons /
                 cons ^ 2 t
                      nil

define      omega
value       (lambda (t) (cons (count-halt nil t) (cons / (cons
             (^ 2 t) nil))))

(omega 0)

expression  (omega 0)
value       (0 / 1)

(omega 1)

expression  (omega 1)
value       (0 / 2)

(omega 2)

expression  (omega 2)
value       (0 / 4)

(omega 3)

expression  (omega 3)
value       (0 / 8)

(omega 8)

expression  (omega 8)
value       (1 / 256)

End of LISP Run

Elapsed time is 1 seconds.


## (c) Simon N Wood
## occupancy likelihood corrected
## Version allowing the generation time to be manipulated while keeping the
## disease progression times fixed.

lfun <- function(theta,link) {
## applies link to theta...
  if (is.matrix(link)) {
    a1 <- link[,2];a2 <- link[,3];link <- link[,1]
  } else {
    a1 <- rep(0,length(theta));a2 <- rep(1,length(theta))
  }
  ii <- link==1
  if (length(ii)) theta[ii] <- log(theta[ii])
  ii <- link==2
  if (length(ii)) theta[ii] <- binomial()$linkfun((theta[ii]-a1[ii])/(a2[ii]-a1[ii]))
  theta
}

ilink <- function(eta,link) {
## apply link inverse and compute dtheta/deta - eta is the unconstrained parameter
  if (is.matrix(link)) {
    a1 <- link[,2];a2 <- link[,3];link <- round(link[,1])
  } else {
    a1 <- rep(0,length(eta));a2 <- rep(1,length(eta))
  }
  theta <- eta
  dtheta <- eta*0+1
  ii <- link==1
  if (length(ii)) {
    dtheta[ii] <- theta[ii] <- exp(eta[ii])
  }
  ii <- link==2
  if (length(ii)) {
    theta[ii] <- binomial()$linkinv(eta[ii])*(a2[ii]-a1[ii]) + a1[ii]
    dtheta[ii] <- binomial()$mu.eta(eta[ii])*(a2[ii]-a1[ii])
  }
  list(theta=theta,dtheta=dtheta)
}

ll <- function(theta,gamma,S0,iaux,daux,dat,Sb=NULL,link=rep(0,length(theta)),plot=FALSE,
               step=1,nbk=rep(2,5),getR=FALSE,lab="",xlab="day") {
## log likelihood for the rep41 covid SEIR+hospital model.  nbk is a vector of overdispersion parameters.
## rep41 uses neg bin kappa = 2 for all - this is very hard to justify for deaths.
  nb <- iaux[1];np <- iaux[2];nc <- iaux[3];ns <- iaux[4]
  nx <- ns*nc*(1+np);
  nyo <- 14
  ny <- nyo*(1+np)
  x <- rep(0,nx)
  for (i in 1:nc) x[(i-1)*ns+1] <- S0[i]
  ii <- 1:length(gamma)+(nc-1)^2
  daux[ii] <- gamma
  n <- max(dat$day)
  th <- ilink(theta,link)
  thetaw <- theta ## original scale
  theta <- th$theta ## parameters on dynamic model specification scale
  if (any(!is.finite(theta))) return(list(l=NA,dl=NA))
  vm <- .C("RK4",yout = as.double(rep(0,ny*n)),xout=as.double(rep(0,nx*n)),x=as.double(x),
          theta=as.double(theta),h=as.double(1/step),t0=as.double(0),n=as.integer(n),nx=as.integer(nx),ny=as.integer(ny),
          ostep =as.integer(step),work=as.double(rep(0,5*nx)),iaux=as.integer(iaux),daux=as.double(daux))
  yout <- matrix(vm$yout,ny,n)

  ## hospital deaths...

  k <- nbk[4]
  y <- dat$death3;
  ynb <- matrix(NA,max(dat$day),7);munb <- matrix(NA,max(dat$day),9)
  ii <- !is.na(y); y<- y[ii];ii <- dat$day[ii]
  mu <- yout[4,ii]
  ynb[ii,4] <- y;munb[ii,4] <- mu
  n.death <- sum(mu)
  ld <- sum(k*log(k/(k+mu)) + y*log(mu/(mu+k)) + lgamma(k+y) - lgamma(k) - lgamma(y+1))
  dld.dmu <- y/mu - (y+k)/(mu+k)
  dld <- drop(yout[1:np*nyo+4,ii]%*%dld.dmu)
  if (plot&&length(y)) {
    ylim=c(range(y,mu));xlim <- range(ii)
    maj <- 2.2;mas <- .7
    pch=19;pex=.4
    plot(ii,y,ylab="",col="grey",ylim=ylim,xlim=xlim,xlab="",pch=pch,cex=pex);
    mtext("deaths",2,maj,cex=mas);mtext(xlab,1,maj,cex=mas)
    lines(ii,mu)
    text(220,ylim[2]*.86,lab)
  }

  ## care home deaths...

  k <- nbk[5]
  y <- dat$death2-dat$death3;ii <- !is.na(y); y<- y[ii];ii <- dat$day[ii]
  mu <- yout[5,ii];n.death <- n.death+ sum(mu)
  ynb[ii,5] <- y;munb[ii,5] <- mu
  lg <- sum(k*log(k/(k+mu)) + y*log(mu/(mu+k)) + lgamma(k+y) - lgamma(k) - lgamma(y+1))
  dlg.dmu <- y/mu - (y+k)/(mu+k)
  dlg <- drop(yout[1:np*nyo+5,ii]%*%dlg.dmu)
  if (plot&&length(y)) {
    points(ii,y,col=2,pch=pch,cex=pex);lines(ii,mu,col=4)
  }

  ## occupancy...

  k <- 100000

  ## total occupancy...
  y0 <- dat$phe_patients;i0 <- dat$day
  ii <- !is.na(y0);y <- sum(y0[ii]);i0 <- i0[ii]
  mu <- sum(yout[2,i0])

  ## log likelihood total occupancy....
  lot <- sum(k*log(k/(k+mu)) + y*log(mu/(mu+k)) + lgamma(k+y) - lgamma(k) - lgamma(y+1))
  dlot.dmu <- y/mu - (y+k)/(mu+k)
  dlot <- rowSums(yout[1:np*nyo+2,i0]) * dlot.dmu

  ## get change in occupancy over the day - difference between in and outflow
  k <- nbk[2] ## overdispersion parameter
  y <- diff(dat$phe_patients);ii <- !is.na(y); y <- y[ii];ii <- dat$day[ii]
  mu1 <- yout[11,ii] # general ward inflow
  mu2 <- yout[12,ii] # general ward outflow
  wi <- rep(1:ceiling(length(y)/7),each=7)[1:length(y)]
  y <- tapply(y,wi,sum) ## aggregate differences by week to avoid unmodelled weekly discharge cycle
  mu1 <- tapply(mu1,wi,sum);mu2 <- tapply(mu2,wi,sum)

  iw <- ii[1]+1:length(y)*7 - 4 ## output to allow over-dispersion update
  ynb[iw,6] <- y;munb[iw,6] <- mu1;munb[iw,7] <- mu2;
  alpha <- y-mu1+mu2;sig <- mu1+mu2

  lo <- sum(-alpha^2/(2*k*sig) - log(k*sig)/2) ## log likelihood occupancy change
  dlo.dmu1 <- alpha/(k*sig) + alpha^2/(2*k*sig^2) - .5/sig
  dlo.dmu2 <- -alpha/(k*sig) + alpha^2/(2*k*sig^2) -.5/sig
  dlo <- t(apply(yout[1:np*nyo+11,ii],1,function(y,wi) tapply(y,wi,sum),wi=wi))%*%dlo.dmu1 +
	 t(apply(yout[1:np*nyo+12,ii],1,function(y,wi) tapply(y,wi,sum),wi=wi))%*%dlo.dmu2
  lo <- lo + lot;
  dlo <- drop(dlo) + dlot

  ## occupancy itself for plotting and return..
  y <- dat$phe_patients;ii <- !is.na(y); y<- y[ii];ii <- dat$day[ii]
  mu <- yout[2,ii]
  ynb[ii,2] <- y;munb[ii,2] <- mu

  if (plot&&length(y)) {
    plot(ii,y,col="grey",ylim=range(c(y,mu)),xlim=xlim,ylab="",xlab="",pch=pch,cex=pex)
    mtext("occupancy",2,maj,cex=mas);mtext(xlab,1,maj,cex=mas)
    lines(ii,mu)
  }

  ## ICU occupancy...
  k <- 20000

  y0 <- dat$phe_occupied_mv_beds;i0 <- dat$day
  ii <- !is.na(y0);y <- sum(y0[ii]);i0 <- i0[ii]
  mu <- sum(yout[3,i0])
  ## log likelihood total icu occupancy
  lut <- sum(k*log(k/(k+mu)) + y*log(mu/(mu+k)) + lgamma(k+y) - lgamma(k) - lgamma(y+1))
  dlut.dmu <- y/mu - (y+k)/(mu+k)
  dlut <- rowSums(yout[1:np*nyo+3,i0]) * dlut.dmu

  ## get likelihood for icu occupancy changes...
  k <- nbk[3] ## overdispersion parameter
  y <- diff(dat$phe_occupied_mv_beds);ii <- !is.na(y); y<- y[ii];ii <- dat$day[ii]
  mu1 <- yout[13,ii] # ICU inflow
  mu2 <- yout[14,ii] # ICU outflow
  wi <- rep(1:ceiling(length(y)/7),each=7)[1:length(y)]
  y <- tapply(y,wi,sum) ## aggregate differences by week to avoid unmodelled weekly discharge cycle
  mu1 <- tapply(mu1,wi,sum);mu2 <- tapply(mu2,wi,sum)

  iw <- ii[1]+1:length(y)*7 - 4
  ynb[iw,7] <- y;munb[iw,8] <- mu1;munb[iw,9] <- mu2;

  alpha <- y-mu1+mu2;sig <- mu1+mu2
  lu <- sum(-alpha^2/(2*k*sig) - log(k*sig)/2) ## log likelihood - icu occupancy change
  dlu.dmu1 <- alpha/(k*sig) + alpha^2/(2*k*sig^2) - .5/sig
  dlu.dmu2 <- -alpha/(k*sig) + alpha^2/(2*k*sig^2) -.5/sig
  dlu <- t(apply(yout[1:np*nyo+13,ii],1,function(y,wi) tapply(y,wi,sum),wi=wi))%*%dlu.dmu1 +
	 t(apply(yout[1:np*nyo+14,ii],1,function(y,wi) tapply(y,wi,sum),wi=wi))%*%dlu.dmu2
  #dlu <- drop(yout[1:np*nyo+13,ii]%*%dlu.dmu1)+drop(yout[1:np*nyo+14,ii]%*%dlu.dmu2)
  lu <- lu + lut
  dlu <- dlu + dlut
  # ICU occupancy itself for plotting and return
  y <- dat$phe_occupied_mv_beds;ii <- !is.na(y); y<- y[ii];ii <- dat$day[ii]
  mu <- yout[3,ii]
  ynb[ii,3] <- y;munb[ii,3] <- mu
  if (plot&&length(y)) {
    points(ii,y,col=2,pch=pch,cex=pex)#xlab="day",ylab="ICU",col="grey",ylim=range(c(y,mu)));
    lines(ii,mu,col=4)
  }

  ## hospitalization...

  y <- dat$phe_admissions; ii <- !is.na(y); y<- y[ii]
  ii <- dat$day[ii] ## cols of yout corresponding to observed data
  k <- nbk[1] ## theta parameter
  mu <- yout[1,ii]
  ynb[ii,1] <- y;munb[ii,1] <- mu
  lh <- sum(k*log(k/(k+mu)) + y*log(mu/(mu+k)) + lgamma(k+y) - lgamma(k) - lgamma(y+1))
  dlh.dmu <- y/mu - (y+k)/(mu+k)
  dlh <- drop(yout[1:np*nyo+1,ii]%*%dlh.dmu)
  #if (plot) par(mfrow=c(2,3));
  if (plot&&length(y)) {
    plot(ii,y,col="grey",ylim=range(c(y,mu)),xlim=xlim,ylab="",xlab="",pch=pch,cex=pex);
    mtext("admissions",2,maj,cex=mas);mtext(xlab,1,maj,cex=mas)
    lines(ii,mu)
  }

  ## serology samples...

  N <- sum(S0[4:13])
  y <- dat$n_positive;ii <- !is.na(y); y<- y[ii];
  n <- dat$total_samples[ii]
  ii <- dat$day[ii]
  mu <- yout[6,ii]/N
  ls <- sum(dbinom(y,n,mu,log=TRUE))
  dls.dmu <- y/mu - (n-y)/(1-mu)
  dls <- drop(yout[1:np*nyo+6,ii]%*%dls.dmu)/N
  if (plot&&length(y)) {
    plot(ii,y/n,ylab="",ylim=range(c(y/n,mu)),col="grey",xlim=xlim,xlab="",pch=pch,cex=pex)
    mtext("P(sero)",2,maj,cex=mas);mtext(xlab,1,maj,cex=mas)
    lines(ii,mu,col=1)
  }

  ## REACT PCR samples...

  N <- sum(S0[2:18])
  y <- dat$react_pos;ii <- !is.na(y); y<- y[ii];
  n <- dat$react_samples[ii]
  ii <- dat$day[ii]
  mu <- yout[7,ii]/N
  lr <- sum(dbinom(y,n,mu,log=TRUE))
  dlr.dmu <- y/mu - (n-y)/(1-mu)
  dlr <- drop(yout[1:np*nyo+7,ii]%*%dlr.dmu)/N
  if (plot&&length(y)) {
    plot(ii,y/n,ylab="",col="grey",xlim=xlim,xlab="",pch=pch,cex=pex);lines(ii,mu,col=1)
    mtext("P(pcr)",2,maj,cex=mas);mtext(xlab,1,maj,cex=mas)
  }

  l=lh+lo+lu+ld+lg+lr+ls ## total log likelihood
  dl=dlh+dlo+dlu+dld+dlg+dlr+dls ## corresponding derivative vector

  if (!is.null(Sb)) { ## add smoothing penalty
    Sb <- drop(Sb %*% theta[1:nb])
    l <- l - sum(theta[1:nb]*Sb)/2
    dl[1:nb] <- dl[1:nb] - Sb
  }
  R <- yout[9,]; R[R<0] <- NA; Rd <- NULL
  if (plot||getR) { ## get the Diekmann version of R...
    gamma_A <- gamma[2];gamma_C <- gamma[3];p_c <- gamma[4]
    Rd <- R
    beta <- yout[10,]
    C <- matrix(daux[1:(nc-1)^2],nc-1,nc-1)[-(nc-1),-(nc-1)]
    n <- max(dat$day)
    xout <- matrix(vm$xout,nx,n)[1:(nc*ns),]
    S <- xout[0:(nc-3)*ns+1,]
    for (i in 1:n) {
      C0 <- S[,i]*C
      K <- beta[i]*rbind(cbind((1-p_c)*C0/gamma_A,(1-p_c)*C0/gamma_C),cbind(p_c*C0/gamma_A,p_c*C0/gamma_C))
      Rd[i] <- abs(eigen(K,only.values = TRUE)$values[1])
    }
  } else xout <- NULL
  if (ncol(link)>3) { ## prior on dynamic params too
     ii <- (nb+1):np
     sig.p <- link[ii,5]
     l <- l - sum((thetaw[ii]-link[ii,4])^2/(2*sig.p^2))
     dprior <- c(rep(0,nb),-(thetaw[ii]-link[ii,4])/sig.p^2)
  } else dprior <- 0
  list(l=l,dl=dl*th$dtheta+dprior,R=R,Rd=Rd,fi=yout[8,],xout=xout,n.death=n.death,munb=munb,ynb=ynb)
} ## ll

thfix <- function(theta,fixi,fixv) {
## if fixi!=NULL then it indexes parameters that have been dropped from the optimization of
## theta, while fixv gives their fixed values. This routine inserts the fixed values into
## theta in the correct place...
  if (!is.null(fixi)) {
    if (length(fixi)!=length(fixv)) stop("fixv wrong length")
    th1 <- rep(0,length(theta)+length(fixi))
    ii <- rep(FALSE,length(th1))
    ii[fixi] <- TRUE
    th1[ii] <- fixv
    th1[!ii] <- theta
    theta <- th1
  }
  theta
} ## thfix

nll <- function(theta,gamma,S0,iaux,daux,dat,Sb,link,step=1,nbk=rep(2,5),fixi=NULL,fixv=NULL) {
## if fixi!=NULL then it indexes parameters that have been dropped from the optimization of
## theta, while fixv gives their fixed values.
 iaux[7] <- 0; ## no derivatives needed
 theta <- thfix(theta,fixi,fixv)
 -ll(theta,gamma,S0,iaux,daux,dat,Sb=Sb,link=link,plot=FALSE,step=step,nbk=nbk)$l
}

nll0 <- function(theta,gamma,S0,iaux,daux,dat,Sb,link,step=1,nbk=rep(2,5),fixi=NULL,fixv=NULL) {
## if fixi!=NULL then it indexes parameters that have been dropped from the optimization of
## theta, while fixv gives their fixed values.
 iaux[7] <- 0; ## no derivatives needed
 theta <- thfix(theta,fixi,fixv)
 ll(theta,gamma,S0,iaux,daux,dat,Sb=Sb,link=link,plot=FALSE,step=step,nbk=nbk)
}

nllg <- function(theta,gamma,S0,iaux,daux,dat,Sb,link,step=1,nbk=rep(2,5),fixi=NULL,fixv=NULL) {
## grad function corresponding to nll
 theta <- thfix(theta,fixi,fixv)
 g <- -ll(theta,gamma,S0,iaux,daux,dat,Sb=Sb,link=link,plot=FALSE,step=step,nbk=nbk)$dl
 if (!is.null(fixi)) g <- g[-fixi]
 g
}

hessian <- function(theta,gamma,S0,iaux,daux,dat,Sb,link,step=1,nbk=rep(2,5),fixi=NULL,fixv=NULL) {
  ## compute Hessian by finite differencing
  nt <- length(theta)
  eps <- 1e-7
  g0 <- nllg(theta,gamma,S0,iaux,daux,dat,Sb,link,step,nbk,fixi,fixv)
  H <- matrix(0,nt,nt)
  for (i in 1:nt) {
    theta1 <- theta;theta1[i] <- theta[i] + eps
    g1 <- nllg(theta1,gamma,S0,iaux,daux,dat,Sb,link,step,nbk,fixi,fixv)
    H[,i] <- (g1-g0)/eps;
  }
  .5*(t(H)+H)
} ## hessian

nll1 <-  function(theta,gamma,S0,iaux,daux,dat,Sb,link,step=1,nbk=rep(2,5),fixi=NULL,fixv=NULL) {
## unused nlm version
 theta <- thfix(theta,fixi,fixv)
 l0 <- ll(theta,gamma,S0,iaux,daux,dat,Sb=Sb,link=link,plot=FALSE,step=step,nbk=nbk)
 nll <- -l0$l
 attr(nll,"gradient") <- -l0$dl
 nll
}

ginv <- function(V,warn=FALSE) { ## generalized inverse
  if (!all(is.finite(V))) return(NULL)
  ev <- eigen(V,symmetric=TRUE)
  d <- ev$values;ii <- d>0
  d[ii] <-1/d[ii];d[!ii] <- 0
  if (warn&&sum(!ii)) warning("indefinite V\n")
  ev$vectors%*%(d*t(ev$vectors))
}

tf <- function(x,a1=.00,a2=.1) { ## transform as applied to b(t)
  ii <- x<0
  x[ii] <- exp(x[ii])
  x[!ii] <- exp(-x[!ii])
  x[ii] <- a1 + (a2-a1)*x[ii]/(1+x[ii])
  x[!ii] <- a1 + (a2-a1)*1/(1+x[!ii])
  x
}

itf <- function(y,a1=.00,a2=.1) { ## transform as applied to b(t)
  y <- (y-a1)/(a2-a1)
  log(y/(1-y))
}

setup.model <- function(location="london",Xtype=2,beta.off = .25,rep41C=FALSE) {
## sets up the information required for a model fit, including fixed parameters,
## data, initial parameter values and limits.

  source("params.r") ## some fixed parameters

  region <- c("east_of_england","london","midlands","north_east_and_yorkshire",
  "north_west","south_east","south_west")

  if (!location %in% region) stop("location wrong")

  source("data.r",local=TRUE) ## obtain the fit data and some other parameters

  load(paste("C_",location,".rda",sep=""))
  ## or use m from sircovid package - problem is that it only matches what is documented
  ## up to age 70 (parameters change but results unchanged)...
  if (rep41C) C <- ch$m[1:18,1:18]

  n <- max(rtr$day) ## number of output steps
  step <- 1 ## steps between output
  h <- 1/step ## step length
  hx <- h/2 ## step at which basis evaluation required
  t <- h*0:(2*step*n)/2 ## when basis evaluation required
  nb <- 80 ## number of b(t) coeffs
  if (Xtype==1) {## adaptive
    t0 <- 45 ## constant b(t) before here
    ii <- t >= t0 ## set up adaptive smooth from t0
    smb <- smoothCon(s(t,k=nb,bs="ad"),data=data.frame(t=t[ii]))[[1]]
    ni <- sum(!ii) ## need to pad model matrix to fill in constant prior to t0
    X0 <- matrix(smb$X[1,],ni,ncol(smb$X),byrow=TRUE)
    Xb <- rbind(X0,smb$X) ## b(t) basis matrix
    Sb <- smb$S ## penalty matrix
    attr(Sb,"rank") <- smb$rank
  } else if (Xtype==2) { ## force b(t) to be constant at start
    ne <- 5
    smb <- smoothCon(s(t,k=nb+ne,bs="bs"),data=data.frame(t=t))[[1]]
    T <- diag(nb+ne)[,-(1:ne)];T[1:ne,1] <- 1
    Xb <- smb$X%*%T ## b(t) basis matrix
    Sb <- t(T)%*%smb$S[[1]]%*%T ## penalty matrix
  } else { ## rep 41
    nb <- length(bk)
    Xb <- matrix(0,length(t),nb)
    Xb[,1] <- as.numeric(t<=bk[1])
    for (i in 1:nb) {
      yk <- bk*0;yk[i] <- 1
      Xb[,i] <- approx(bk,yk,t,rule=2)$y
    }
    Sb <- NULL
  }

  b0 <- c(rep(-2.4,5),-2.404542,-2.468239,-2.676757,-3.068759,-3.510927,
  -3.833448,-3.971020,-3.999736,rep(-4,10),-3.999977,-3.987959,-3.920592,
  -3.752347,-3.506797,-3.277703,-3.147313,-3.104178,rep(-3.5,14))
  t0 <- 0:44*7.5+7
  b0 <- exp(approx(t0,b0,t,rule=2)$y)
  a1 <- 0; a2 <- 0.1
  b0[b0>a2] <- a1 + (a2-a1)*.95
  b0[b0<a1] <- a1 + (a2-a1)*.05
  b0 <- itf(b0,a1,a2)
  beta <- coef(lm(b0~Xb-1)) ## initial b(t) parameters
  beta <- beta - beta.off

  ## set up param vector
  eps <- 0.1; m_chw <- 4e-6; m_chr <- 4e-6
  t0 <- 20;p_g <- 0.6;p_h_max <- 0.45
  mu_ic <- .9; mu_d <- .9; p_ic_max <- .3
  p_icd_max <- .6;p_wd_max <- .3;p_hd_max <- .37
  gamma_G <- .4;
  gamma_IC_Wr <- .0641;gamma_Wr <- .16;gamma_Hr<- 0.0935

  theta <- c(beta,eps,m_chw,m_chr,t0,p_h_max,p_g,mu_ic,p_ic_max,p_icd_max,mu_d,p_wd_max,p_hd_max,gamma_G,
             gamma_IC_Wr,gamma_Wr,gamma_Hr)
  names(theta)[(nb+1):length(theta)] <- c("eps","m_chw","m_chr","t0", "p_h_max","p_g","mu_ic","p_ic_max",
                             "p_icd_max","mu_d","p_wd_max","p_hd_max","gamma_G","gamma_IC_Wr","gamma_Wr","gamma_Hr")

  link <- c(rep(0,nb),1,1,1,0,2,2,2,2,2,2,2,2,1,1,1,1) ## link types: 0 - I(), 1 - log, 2 - logit
  a1 <-   c(rep(0,nb),0,0,0,0,0,0,.66,.14,.57,.66,.25,.36,0,0,0,0) ## lower logistic limit
  a2 <-   c(rep(0,nb),0,0,0,0,1,1, 1 ,.36,.77,  1,.46,.56,0,0,0,0)  ## upper logistic limit
  ### prior mean on working scale...
  mup <- c(rep(0,nb),-.7,-12.7,-12.7,30,1.1,1.1,-1,-.2,0,-1,0,0,-1,-2.75,-1.8,-2.37)
  sdp <- c(rep(NA,nb),2,2,2,10,2,2,2,2,2,2,1,1,2,2,2,2) ## prior s.d. on working scale
  link <- cbind(link,a1,a2,mup,sdp)
  ## fixed param vector
  p_c <- 0.6 # .6 ## Knock et al
  inoc_sig <- 7.5 # arbitrary
  p_star <- 0.25 ## Knock et al
  f_start <- 92 ## improvement start
  f_end <- 152  ## improvement end
  gamma_U <- .5 ## Table S7
  ## gamma_E, gamma_C and gamma_ph should keep mean time from infection to hospital at
  ## 12.3 days to match cited literature
  #gamma_E <- .44 ## Table S2 or use ch$gamma_E based on early lauer paper
  #gamma_E <- 1/2.9 ## based on McAloon meta-analysis!
  gamma_E <- 1/1.5 ## mean 3 days to infective
  #gamma_C <- .25 ## Table S2 - based on equating the median and mean of an exponential!
  #gamma_C <- 1/6.5 ## Based on cited Docherty paper *mean* for males and females (see supp)
  gamma_C <- 1/4 ## mean 4 days infective => generation time 6.2 (brought down by asymptomatics)
  gamma_ph <- 1/5.3 ## 5.3 is the length of the post I_C pre hospital phase (2.8 without correction)
  gamma_A <- ch$gamma_asympt
  gamma_IC_Wr <- .0641 ## Table S2
  gamma_IC_Wd <- .14 ## Table S2
  gamma_IC_d <- .17 ## Table S2
  gamma_Wr <- .16  ## Table S2
  gamma_Wd <- .12  ## Table S2
  gamma_Hr <- .0935 ## Table S2
  gamma_Hd <- .19 ## Table S2
  gamma_S <- 1/13 ## Table S7
  p_S <- .85 ## Table S7

  gamma0 <- c(gamma_E,gamma_A,gamma_C,p_c,inoc_sig,gamma_ph,p_star,
           f_start,f_end,ch$gamma_ICU_D,gamma_U,gamma_IC_Wr,gamma_IC_Wd,gamma_IC_d,
	   gamma_Wr,gamma_Wd,gamma_Hr,gamma_Hd,ch$gamma_PCR_pre,
           ch$gamma_PCR_pos,gamma_S,p_S)

  names(gamma0) <- c("gamma_E","gamma_A","gamma_C","p_c","inoc_sig","gamma_ph","p_star",
  "f_start","f_end","gamma_IC_pre","gamma_U","gamma_IC_Wr","gamma_IC_Wd","gamma_IC_d",
  "gamma_Wr","gamma_Wd","gamma_Hr","gamma_Hd","gamma_P","gamma_Po","gamma_S","p_S")

  gamma <- c(gamma0,psi.h,psi.ic,psi.icd,psi.wd,psi.hd) ## 19 vector
  ng <- length(gamma)
  np <- length(theta)
  nc <- 19 ## classes
  ns <- 37 ## states per class
  nk <- prod(dim(Xb))
  deriv <- 1
  iaux <- c(nb,np,nc,ns,ng,nk,deriv,-1)
  daux <- c(C,gamma,t(Xb),hx,rep(0,nb+2*(nc+nc*np)))
  S0=ch$N_tot
  thetaw <- lfun(theta,link=link);fixi <- fixv <- NULL
  arg <- list(location=location,gamma=gamma,S0=S0,thetaw=thetaw,iaux=iaux,daux=daux,dat=rtr,Sb=Sb,link=link,step=step)
  arg
} ## setup.model

nlnb <- function(theta,y,mu) {
## negative log lik for NB
  ii <- is.na(y)|is.na(mu)
  y <- y[!ii];mu <- mu[!ii]
  -sum(theta*log(theta/(theta+mu)) + y*log(mu/(mu+theta)) + lgamma(theta+y) - lgamma(theta))
}

fit.model <- function(arg) {
## fit model using Fellner Schall sp updates...
  if (is.null(arg$Sb)) { m <- 0; Sb <- NULL} else
  if (is.list(arg$Sb)) {
    lambda <- rep(10,length(arg$Sb))
    Sb <- arg$Sb[[1]]*lambda[1]
    m <- length(arg$Sb)
    if (m>1) for (i in 2:m) Sb <- Sb +  arg$Sb[[i]]*lambda[i]
    if (m==1) arg$Sb <- arg$Sb[[1]]
  } else {
    m <- 1
    Sb <- arg$Sb * 10
  }
  thetaw <- if (is.null(arg$fixi)) arg$thetaw else arg$thetaw[-arg$fixi]
  er <- optim(thetaw,nll,gr=nllg,method="BFGS",control=list(maxit=400),gamma=arg$gamma,S0=arg$S0,
            iaux=arg$iaux,daux=arg$daux,dat=arg$dat,Sb=Sb,link=arg$link,step=arg$step,
	    nbk=rep(2,5),fixi=arg$fixi,fixv=arg$fixv)
  cat(arg$location," ")

  er$par -> thetaw -> thetaw0

  if (is.null(arg$Sb)) { m <- 0; Sb <- NULL} else
  if (is.list(arg$Sb)) {
    lambda <- rep(10,length(arg$Sb))
    Sb <- arg$Sb[[1]]*lambda[1]
    m <- length(arg$Sb)
    if (m>1) for (i in 2:m) Sb <- Sb +  arg$Sb[[i]]*lambda[i]
  } else {
    m <- 1; lambda <- 10
    Sb <- arg$Sb * lambda
  }
  nrep <- if (m>0) 20 else 1 ## based on prelim run

  nbk <- c(2,2,2,2000,50) ## admissions, ward and icu occupancy, hospital deaths, care home deaths
  k1 <- c(40,100,100,2000,2000) ## upper limits on overdispersion param
  for (i in 1:nrep) {
    er0 <- er
    er <- optim(thetaw,nll,gr=nllg,method="BFGS",control=list(maxit=400),gamma=arg$gamma,S0=arg$S0,
            iaux=arg$iaux,daux=arg$daux,dat=arg$dat,Sb=Sb,link=arg$link,step=arg$step,
	    nbk=nbk,fixi=arg$fixi,fixv=arg$fixv,hessian=FALSE)
    ## get Hessian without Sb first - check +ve semidef
    H <- hessian(er$par,arg$gamma,arg$S0,arg$iaux,arg$daux,arg$dat,Sb=NULL,link=arg$link,
                 step=arg$step,nbk=nbk,arg$fixi,arg$fixv)
    eh <- eigen(H)
    if (any(eh$values<0)) { ## find nearest +ve semi definite
      eh$values[eh$values<0] <- 0
      H <- eh$vectors %*% (eh$values*t(eh$vectors))
    }
    Hp <- H ## penalized version
    if (!is.null(Sb)) {
      nb <- ncol(Sb)
      Hp[1:nb,1:nb] <- Hp[1:nb,1:nb] + Sb
    }

    ## update nb theta...
    l0 <- nll0(thetaw,gamma=arg$gamma,S0=arg$S0,iaux=arg$iaux,daux=arg$daux,
            dat=arg$dat,Sb=Sb,link=arg$link,step=arg$step)
    for (i in c(1,5)) { ## optimize log lik
      nbk[i] <- optimize(nlnb,interval=c(2,k1[i]),y=l0$ynb[,i],mu=l0$munb[,i])$minimum
    }
    for (i in 2:3) { ## update occupancy rates overdispersion
      y <- l0$ynb[,i+4];ii <- !is.na(y);y <- y[ii]
      mu1 <- l0$munb[ii,i*2+2]
      mu2 <- l0$munb[ii,i*2+3]
      k.mle <- mean((y-mu1+mu2)^2/(mu1+mu2))
      k.mle <- if (k.mle < 1) 1 else { if (k.mle>k1[i]) k1[i] else k.mle}
      nbk[i] <- k.mle
    }
    er$par -> thetaw
    thetaw <- thfix(er$par,arg$fixi,arg$fixv)
    Vb <- ginv(Hp,warn=TRUE)
    if (is.null(Vb)) break
    nb <- arg$iaux[1]
    b <- thetaw[1:nb]
    if (m>1) {
      Si <- ginv(Sb)
      if (is.null(Si)) { Vb <- NULL; break}
      for (i in 1:m) {
        fac <- drop((sum(Si*arg$Sb[[i]]) - sum(Vb[1:nb,1:nb]*arg$Sb[[i]]))/t(b)%*%arg$Sb[[i]]%*%b)
	if (fac<0.2) fac <- .2
	if (fac>5) fac <- 5
        lambda[i] <- lambda[i]*fac
      }

      Sb <- arg$Sb[[1]]*lambda[1]
      for (i in 2:m) Sb <- Sb +  arg$Sb[[i]]*lambda[i]
    } else if (m==1) {
      fac <- drop(((nb-2)/lambda - sum(Vb[1:nb,1:nb]*arg$Sb))/t(b)%*%arg$Sb%*%b)
      if (fac<0.2) fac <- .2
      if (fac>5) fac <- 5
      lambda <- lambda*fac
      Sb <- lambda*arg$Sb
    }
    if (m>0) cat(arg$region,": ",lambda,"\n")
  }
  if (is.null(Vb)) {
    er <- er0
    er$par -> thetaw
    Vb <- ginv(er$hessian)
  }
  list(thetaw=thetaw,theta=ilink(thetaw,arg$link)$theta,Vb=Vb,H=Hp,lambda=lambda,nbk=nbk)
} ## fit.model

check.model <- function(arg,plot=TRUE,deriv=FALSE) {
## checks if initial params gtive something remotely reasonable
  arg$iaux[7] <- as.numeric(deriv)
  l0 <- ll(arg$thetaw,arg$gamma,arg$S0,arg$iaux,arg$daux,arg$dat,Sb=NULL,link=arg$link,plot=plot,step=arg$step)
}

check.derivs <- function(thetaw,arg,eps = 1e-6) {
## checks derivatives of penalized log likelihood. Note currently not checking with smoothing penalty.
  l0 <- ll(thetaw,arg$gamma,arg$S0,arg$iaux,arg$daux,arg$dat,Sb=NULL,link=arg$link,plot=FALSE,step=arg$step)
  fd <- l0$dl*0
  arg$iaux[7] <- 0
  for (i in 1:length(fd)) {
    theta1 <- thetaw;theta1[i] <- theta1[i] + eps
    l1 <- ll(theta1,arg$gamma,arg$S0,arg$iaux,arg$daux,arg$dat,Sb=NULL,link=arg$link,plot=FALSE,step=arg$step)
    fd[i] <- (l1$l-l0$l)/eps
    cat(".")
  }
  cat("\n")
  plot(l0$dl,fd);abline(0,1)
  list(dl=l0$dl,fd=fd,l=l0$l)
}

dRfi <- function(arg) {
## lazy evaluation of derivatives of R and incidence trajectories w.r.t. parameters, assuming thetaw and Vb added to arg
  eps = 1e-5
  thetaw <- arg$thetaw
  l0 <- ll(thetaw,arg$gamma,arg$S0,arg$iaux,arg$daux,arg$dat,Sb=NULL,link=arg$link,plot=FALSE,step=arg$step,getR=TRUE)
  dR <- df <- matrix(0,length(l0$Rd),length(thetaw))
  for (i in 1:length(thetaw)) {
    theta1 <- thetaw;theta1[i] <- theta1[i] + eps
    l1 <- ll(theta1,arg$gamma,arg$S0,arg$iaux,arg$daux,arg$dat,Sb=NULL,link=arg$link,plot=FALSE,step=arg$step,getR=TRUE)
    dR[,i] <- (log(l1$Rd)-log(l0$Rd))/eps
    df[,i] <- (log(l1$fi)-log(l0$fi))/eps
  }
  list(dR=dR,df=df,se.r=rowSums((dR%*%arg$Vb) * dR)^.5,se.f=rowSums((df%*%arg$Vb) * df)^.5,fi=l0$fi,Rd=l0$Rd)
} ## dRfi

plot.fit <- function(fit,arg) {
## quick plot of fit to data + R and incidence.
  l0 <- ll(fit$thetaw,arg$gamma,arg$S0,arg$iaux,arg$daux,arg$dat,Sb=NULL,link=arg$link,plot=TRUE,step=arg$step)
  X11()
  par(mfrow=c(2,2))
  plot(log(l0$Rd),xlim=c(50,150));abline(0,0);abline(v=84)
  plot(log(l0$Rd));abline(1,0);abline(v=84)
  plot(l0$Rd,xlim=c(50,150));abline(1,0);abline(v=84)

  plot(l0$fi,xlim=c(50,150));abline(v=84)

} ## plot.fit

###############################################################################
setwd("~sw283/research.notes/covid19/rep41/code/albus") ## Data & Code location
###############################################################################

library(mgcv);library(parallel)
dyn.load("albus-gl.so")

region <- c("east_of_england","london","midlands","north_east_and_yorkshire",
  "north_west","south_east","south_west")

rlab <- c("East","London","Midlands","N.E. & Yorkshire", "North West", "South East", "South West")

## setup regional fits...
arg <- list()
for (i in 1:7) arg[[i]] <-setup.model(region[i],Xtype=1,beta.off=.75,rep41C=FALSE)
names(arg) <- rlab
load("thetaw0-g.rda")
for (i in 1:7) {
  arg[[i]]$region <- rlab[i]
  arg[[i]]$thetaw <- thetaw0 ## initialize from old fit to midlands to speed up
}

## par(mfrow=c(2,3));check.model(arg[[1]])
## plot.fit(er,arg[[1]])
## system.time(fd <- check.derivs(arg[[1]]$thetaw,arg[[1]]));fd$dl[-(1:80)];fd$fd[-(1:80)]

system.time(er <- mclapply(arg,fit.model,mc.cores=7))

for (i in 1:7) { ## add fit results to arg list
  arg[[i]]$thetaw <- er[[i]]$thetaw
  arg[[i]]$Vb <- er[[i]]$Vb
}
## get derivatives of R and fi (incidence) w.r.t. parameters
system.time(dd <- mclapply(arg,dRfi,mc.cores=7))

# for (i in 1:7) arg[[i]]$iaux[8] <- 83 ## freeze b(t) at b(83)

## check all fits and compute total incidence and average R -
## R is number of new infections per existing infection, so
## must be weighted by existing infectives.
ns <- arg[[1]]$iaux[4]
nc <- arg[[1]]$iaux[3]
ii <- rep((0:(nc-3))*ns,each=2)+4:5 ## index of all infectives outside care homes
n.deaths <- 0

ps <- FALSE
if (ps) postscript("fits.eps",horizontal=F,height=9,width=11)
par(mfrow=c(7,5),mar=c(3.5,4,0,0))# par(mfcol=c(5,7),mar=c(4,4,1,1))
xlab=""
for (k in 1:7) {
  arg[[k]]$iaux[7] <- 0 ## turn off derivatives
  if (k==7) xlab="day"
  l0 <- ll(er[[k]]$thetaw,arg[[k]]$gamma,arg[[k]]$S0,arg[[k]]$iaux,arg[[k]]$daux,arg[[k]]$dat,Sb=NULL,
        link=arg[[k]]$link,plot=TRUE,step=arg[[k]]$step,getR=TRUE,lab=arg[[k]]$region,xlab=xlab)
  n.deaths <- n.deaths + l0$n.death
  arg[[k]]$iaux[7] <- 1
  Ik <- colSums(l0$xout[ii,])
  rep <- 1000;n <- length(l0$Rd)
  if (k==1) {
    R <- exp(log(dd[[1]]$Rd) + matrix(rnorm(n*rep),n,rep)*dd[[1]]$se.r)*Ik
    f <- exp(log(dd[[1]]$fi) + matrix(rnorm(n*rep),n,rep)*dd[[1]]$se.f)
    Rd <- dd[[k]]$Rd*Ik
    ftot <- dd[[k]]$fi
    Itot <- Ik
  } else {
    R <- R + exp(log(dd[[k]]$Rd) + matrix(rnorm(n*rep),n,rep)*dd[[k]]$se.r)*Ik
    f <- f + exp(log(dd[[k]]$fi) + matrix(rnorm(n*rep),n,rep)*dd[[k]]$se.f)
    Itot <- Itot + Ik
    Rd <- Rd+ dd[[k]]$Rd*Ik
    ftot <-ftot + dd[[k]]$fi
  }
  #text(200,.01,names(arg)[k])
  #X11()
}
if (ps) dev.off()

Rd <- Rd/Itot
Rav <- R/Itot
Rci <- apply(Rav,1,quantile,prob=c(.025,.975))
fci <- apply(f,1,quantile,prob=c(.025,.975))

for (j in 1:2) {
if (j==1) {
  xlim <- c(50,150);xpos <- 110
  fn <- "fw-gc.eps"
} else {
  xlim <- c(60,320);xpos <-150
  fn <- "w2-gc.eps"
}
vt <- c(84,216,245,258,288,310)

if (ps) postscript(fn) else X11()
par(mfrow=c(2,2),mar=c(5,5,1,1))
t <- 1:length(Rd)
c1 <- 1.3
plot(ftot,xlim=xlim,type="l",ylim=c(0,max(fci[2,50:150])),xlab="day",ylab="incidence",cex.lab=c1)
lines(t,fci[1,],lty=2);lines(t,fci[2,],lty=2)
abline(v=vt)

plot(dd[[1]]$fi,xlim=xlim,ylim=c(0,70000),type="l",lwd=3,xlab="day",ylab="incidence",cex.lab=c1)
lines(t,exp(log(dd[[1]]$fi)+dd[[1]]$se.f*2),lty=2)
lines(t,exp(log(dd[[1]]$fi)-dd[[1]]$se.f*2),lty=2)
text(xpos,20000,arg[[1]]$region)
for (k in 2:7) {
  lines(dd[[k]]$fi,col=k,lwd=3)
  text(xpos,10000+k*10000,arg[[k]]$region,col=k)
  lines(t,exp(log(dd[[k]]$fi)+dd[[k]]$se.f*2),lty=2,col=k)
  lines(t,exp(log(dd[[k]]$fi)-dd[[k]]$se.f*2),lty=2,col=k)
}
abline(v=vt)
plot(Rd,xlim=xlim,ylim=c(0,4),type="l",lwd=1,xlab="day",ylab="R",cex.lab=c1)
lines(t,Rci[1,],lty=2);lines(t,Rci[2,],lty=2)

abline(1,0);abline(v=vt)

plot(log(dd[[1]]$Rd),xlim=xlim,ylim=c(-2,2),type="l",lwd=3,xlab="day",ylab="log(R)",cex.lab=c1)
lines(t,log(dd[[1]]$Rd)+dd[[1]]$se.r*2,lty=2)
lines(t,log(dd[[1]]$Rd)-dd[[1]]$se.r*2,lty=2)
text(xpos,.35,arg[[1]]$region)
for (k in 2:7) {
  lines(log(dd[[k]]$Rd),col=k,lwd=3)
  lines(t,log(dd[[k]]$Rd)+dd[[k]]$se.r*2,lty=2,col=k)
  lines(t,log(dd[[k]]$Rd)-dd[[k]]$se.r*2,lty=2,col=k)
  text(xpos,.1+k*.25,arg[[k]]$region,col=k)
}
abline(0,0);abline(v=vt)
if (ps) dev.off()
}


# create an LD decay plot from vcftools output

require(data.table)
# require(data.table, lib.loc="/projects/cees/lib/R_packages/") # on cod node

require(RColorBrewer)

######################
# calculate LD decay
######################

# read in data on cod node
dat14 <- fread('zcat analysis/LOF_S_14.geno.ld')
dat11 <- fread('zcat analysis/LOF_S_11.geno.ld')
dat07 <- fread('zcat analysis/LOF_07.geno.ld')
dat40 <- fread('zcat analysis/CAN40.geno.ld')
datMod <- fread('zcat analysis/CANMod.geno.ld')

# remove ^ from a column name
setnames(dat14, 5, 'r2')
setnames(dat11, 5, 'r2')
setnames(dat07, 5, 'r2')
setnames(dat40, 5, 'r2')
setnames(datMod, 5, 'r2')

# calculate distance
dat14[,dist:=abs(POS2-POS1)]
dat11[,dist:=abs(POS2-POS1)]
dat07[,dist:=abs(POS2-POS1)]
dat40[,dist:=abs(POS2-POS1)]
datMod[,dist:=abs(POS2-POS1)]

# plot raw data
#dat[sample(1:nrow(dat), 10000),plot(dist, r2)] # noisy

# calculate averages within bins (like Bario et al. 2016 eLife)
stp1 <- 5 # step size for small distances
thresh <- 50 # use stp2 above this distance
stp2 <- 500

dat14[,distclass:=floor(dist/stp1)*stp1+stp1/2] # calculate a distance class
dat14[dist>thresh,distclass:=floor(dist/stp2)*stp2+stp2/2] # calculate a distance class
dat11[,distclass:=floor(dist/stp1)*stp1+stp1/2] # calculate a distance class
dat11[dist>thresh,distclass:=floor(dist/stp2)*stp2+stp2/2] # calculate a distance class
dat07[,distclass:=floor(dist/stp1)*stp1+stp1/2] # calculate a distance class
dat07[dist>thresh,distclass:=floor(dist/stp2)*stp2+stp2/2] # calculate a distance class
dat40[,distclass:=floor(dist/stp1)*stp1+stp1/2] # calculate a distance class
dat40[dist>thresh,distclass:=floor(dist/stp2)*stp2+stp2/2] # calculate a distance class
datMod[,distclass:=floor(dist/stp1)*stp1+stp1/2] # calculate a distance class
datMod[dist>thresh,distclass:=floor(dist/stp2)*stp2+stp2/2] # calculate a distance class

bins14 <- dat14[!is.na(r2),.(r2ave=mean(r2), r2sd=sd(r2), r2l95=quantile(r2,probs=0.025), r2u95=quantile(r2,probs=0.975), r2l75=quantile(r2,probs=0.125), r2u75=quantile(r2,probs=0.875), r2n=.N), by=distclass] # average within distance classes
bins11 <- dat11[!is.na(r2),.(r2ave=mean(r2), r2sd=sd(r2), r2l95=quantile(r2,probs=0.025), r2u95=quantile(r2,probs=0.975), r2l75=quantile(r2,probs=0.125), r2u75=quantile(r2,probs=0.875), r2n=.N), by=distclass]
bins07 <- dat07[!is.na(r2),.(r2ave=mean(r2), r2sd=sd(r2), r2l95=quantile(r2,probs=0.025), r2u95=quantile(r2,probs=0.975), r2l75=quantile(r2,probs=0.125), r2u75=quantile(r2,probs=0.875), r2n=.N), by=distclass]
bins40 <- dat40[!is.na(r2),.(r2ave=mean(r2), r2sd=sd(r2), r2l95=quantile(r2,probs=0.025), r2u95=quantile(r2,probs=0.975), r2l75=quantile(r2,probs=0.125), r2u75=quantile(r2,probs=0.875), r2n=.N), by=distclass]
binsMod <- datMod[!is.na(r2),.(r2ave=mean(r2), r2sd=sd(r2), r2l95=quantile(r2,probs=0.025), r2u95=quantile(r2,probs=0.975), r2l75=quantile(r2,probs=0.125), r2u75=quantile(r2,probs=0.875), r2n=.N), by=distclass]

bins14[,r2se:=r2sd/r2n]
bins11[,r2se:=r2sd/r2n]
bins07[,r2se:=r2sd/r2n]
bins40[,r2se:=r2sd/r2n]
binsMod[,r2se:=r2sd/r2n]

setkey(bins14, distclass)
setkey(bins11, distclass)
setkey(bins07, distclass)
setkey(bins40, distclass)
setkey(binsMod, distclass)

# label by population
bins14[,pop:='LOF_S_14']
bins11[,pop:='LOF_S_11']
bins07[,pop:='LOF_07']
bins40[,pop:='CAN40']
binsMod[,pop:='CANMod']

# merge
bins <- rbind(bins07, bins11, bins14, bins40, binsMod)

# write out
write.csv(bins, file='analysis/ld_decay.csv')

###############
# plot
###############
bins <- fread('analysis/ld_decay.csv')
cols <- brewer.pal(5, 'Set1')
cex=0.5

# plot binned data
quartz(width=3, height=3)
# pdf(width=3, height=3, file='figures/ld_decay.pdf')
par(mai=c(0.5, 0.5, 0.3, 0.05), cex.axis=0.7, las=1, mgp=c(1.5, 0.3, 0), tcl=-0.15)
bins[pop=='LOF_07',plot(distclass, r2ave, ylim=c(0,0.7), type='o', xlab='Distance (bp)', ylab='Average correlation (r2)', cex=cex, main='LD decay', log='x', col=cols[1])]
bins[pop=='LOF_S_11',lines(distclass, r2ave, type='o', cex=cex, col=cols[2])]
bins[pop=='LOF_S_14',lines(distclass, r2ave, type='o', cex=cex, col=cols[3])]
bins[pop=='CAN40',lines(distclass, r2ave, type='o', cex=cex, col=cols[4])]
bins[pop=='CANMod',lines(distclass, r2ave, type='o', cex=cex, col=cols[5])]

bins[pop=='LOF_07',lines(c(distclass, distclass), c(r2ave-1.96*r2se, r2ave+1.96*r2se), col=cols[1]), by=distclass] # 95% CI. too small to be visible
bins[pop=='LOF_S_11',lines(c(distclass, distclass), c(r2ave-1.96*r2se, r2ave+1.96*r2se), col=cols[2]), by=distclass]
bins[pop=='LOF_S_14',lines(c(distclass, distclass), c(r2ave-1.96*r2se, r2ave+1.96*r2se), col=cols[3]), by=distclass]
bins[pop=='CAN40',lines(c(distclass, distclass), c(r2ave-1.96*r2se, r2ave+1.96*r2se), col=cols[4]), by=distclass]
bins[pop=='CANMod',lines(c(distclass, distclass), c(r2ave-1.96*r2se, r2ave+1.96*r2se), col=cols[5]), by=distclass]

legend('topright', legend=c('LOF_07', 'LOF_S_11', 'LOF_S_14', 'CAN40', 'CANMod'), col=cols, pch=1, lty=1, bty='n', cex=0.6)

dev.off()


# Data frame
continents_df <- data.frame(
    continents = c("Africa", "Antarctica", "Asia", "Europe", "North America", "South America", "Oceania"),
    area = c(30.3, 14, 44.5, 10.1, 24.7, 17.8, 8.6),
    population = c(1287.9, 0.004, 4545.1, 742.6, 587.6, 428.2, 41.2),
    shares_border = c(TRUE, FALSE, TRUE, TRUE, TRUE, TRUE, FALSE)
)

# Check structure of data frame
str(continents_df)

# Comparing data frame selections
africa_area <- continents_df[1, "area"]
asia_area <- continents_df[3, "area"]
africa_area > asia_area

# Only show data that's TRUE
continents_df[shares_border, ]

# Ordering data frame
pop_order <- order(continents_df$population, decreasing = TRUE)
continents_df[pop_order, ]


############################################################################################
## Using IntNMF on (i) Simulated data and (ii) Real data from TCGA glioblastoma studies
##
## Date: June 18, 2021
############################################################################################

## InterSIM
library(InterSIM)
library(IntNMF)

rm(list=ls())
###---------------------------------------------------------------------------------
### 1. Simulation of multiple types of 'omic data
###---------------------------------------------------------------------------------
#prop <- c(0.65,0.35)
#prop <- c(0.30,0.40,0.30)
prop <- c(0.20,0.30,0.27,0.23)
#prop <- c(0.20,0.25,0.10,0.30,0.15)
#prop <- c(0.15,0.20,0.10,0.25,0.15,0.10,0.05)
effect <- 2.0

sim.D <- InterSIM(n.sample = 100,
					cluster.sample.prop = prop,
					delta.methyl = effect,
					delta.expr = effect,
					delta.protein = effect,
					p.DMP = 0.2,
					p.DEG = NULL, # proportion of DE mRNA, if NULL (default) mRNAs mapped by DE CpGs will be selected
					p.DEP = NULL, # proportion of DE protein, if NULL (default) proteins mapped by DE mRNAs will be selected
					sigma.methyl = NULL, # Covariance structure of methylation data, if NULL precomputed values will be used
					sigma.expr = NULL, # Covariance structure mRNA data, if NULL precomputed values will be used
					sigma.protein = NULL, # Covariance structure Protein data, if NULL precomputed values will be used
					cor.methyl.expr = NULL, # Correlation between methylation and mRNA, if NULL precomputed values will be used
					cor.expr.protein = NULL, # Correlation between mRNA and protein, if NULL precomputed values will be used
					do.plot = TRUE, # TRUE to generate heatmap, default is FALSE
					sample.cluster = TRUE, # For visualization purpose only
					feature.cluster = TRUE)
sim.methyl <- sim.D$dat.methyl
sim.expr <- sim.D$dat.expr
sim.protein <- sim.D$dat.protein
true.cluster.assignment <- sim.D$clustering.assignment
head(true.cluster.assignment)

## Visualization using T-Distributed Stochastic Neighbor Embedding (t-SNE)
# 1. Maaten, L. Van Der, 2014. Accelerating t-SNE using Tree-Based Algorithms. Journal of Machine
#    Learning Research, 15, p.3221-3245.
# 2. van der Maaten, L.J.P. & Hinton, G.E., 2008. Visualizing High-Dimensional Data Using t-SNE.
#    Journal of Machine Learning Research, 9, pp.2579-2605.

library(Rtsne)
library(rgl) #  3D Visualization Using OpenGL

k <- length(unique(true.cluster.assignment$cluster.id))
cols = 1:k
names(cols) = sort(unique(true.cluster.assignment$cluster.id))

dd <- sim.expr
Dist <- dist(dd)
tsne <- Rtsne(Dist, initial_dims = 10, check_duplicates = FALSE, pca = F, perplexity=15, theta=0.5, dims=2, is_distance=TRUE)
head(tsne$Y)
dim(tsne$Y)
d.plot <- tsne$Y

windows(width=5, height=5)
plot(d.plot, xlab="tSNE 1",ylab="tSNE 2",pch=16,main="")
for (i in 1:k)
	{
	dd <- d.plot[true.cluster.assignment$cluster.id==i,]
	points(dd, col=cols[i],pch=16,cex=1.2)
	}

###---------------------------------------------------------------------------------
### 2. Using IntNMF on the simulated data
###---------------------------------------------------------------------------------
rm(list=ls())
library(IntNMF)

#prop <- c(0.65,0.35)
#prop <- c(0.30,0.40,0.30)
prop <- c(0.20,0.30,0.27,0.23)
effect <- 2.5

sim.D <- InterSIM(n.sample=100, cluster.sample.prop=prop, delta.methyl=effect, delta.expr=effect, delta.protein=effect,
			p.DMP=0.25, p.DEG=NULL, p.DEP=NULL, do.plot=F, sample.cluster=T, feature.cluster=T)
dat1 <- sim.D$dat.methyl
dat2 <- sim.D$dat.expr
dat3 <- sim.D$dat.protein
true.cluster.assignment <- sim.D$clustering.assignment

## Make all data positive by shifting to positive direction.
## Also rescale the datasets so that they are comparable.
if (!all(dat1>=0)) dat1 <- pmax(dat1 + abs(min(dat1)), .Machine$double.eps)
dat1 <- dat1/max(dat1)
if (!all(dat2>=0)) dat2 <- pmax(dat2 + abs(min(dat2)), .Machine$double.eps)
dat2 <- dat2/max(dat2)
if (!all(dat3>=0)) dat3 <- pmax(dat3 + abs(min(dat3)), .Machine$double.eps)
dat3 <- dat3/max(dat3)
# The function nmf.mnnals requires the samples to be on rows and variables on columns.
dat1[1:5,1:5]
dat2[1:5,1:5]
dat3[1:5,1:5]
dat <- list(dat1,dat2,dat3)

# Find optimum number of clusters for the data
opt.k <- nmf.opt.k(dat=dat, n.runs=5, n.fold=5, k.range=2:6, result=TRUE, make.plot=TRUE, progress=TRUE)
# Find clustering assignment for the samples
fit <- nmf.mnnals(dat=dat, k=4, maxiter=200, st.count=20, n.ini=5, ini.nndsvd=TRUE, seed=TRUE)
table(fit$clusters)
fit$clusters[1:10]

## Adjusted rand index between true and IntNMF assigned cluster membership
adjustedRandIndex(fit$clusters,true.cluster.assignment$cluster.id)

## Cluster Purity
ClusterPurity(ComputedClusters=fit$clusters, TrueClasses=true.cluster.assignment$cluster.id)

## Cluster Entropy
ClusterEntropy(ComputedClusters=fit$clusters, TrueClasses=true.cluster.assignment$cluster.id)

###---------------------------------------------------------------------------------
### 3. Using IntNMF on the real data on TCGA glioblastoma studies
###---------------------------------------------------------------------------------
rm(list=ls())
library(RColorBrewer)
library(InterSIM)
library(IntNMF)

# Read example data, TCGA studies on glioblastoma
load("C:/Users/pchalise/Desktop/MoffittCancerCenterBioDataClub_18June2021/gbm.rda")
#str(gbm)
d1 <- dat1 <- gbm$cn
d2 <- dat2 <- gbm$methylation
d3 <- dat3 <- gbm$exp
rownames(d1) <- rownames(dat1) <- substr(rownames(dat1),1,12)
rownames(d3) <- rownames(dat3) <- substr(rownames(dat3),1,12)
dat1[1:5,1:5];dat2[1:5,1:5];dat3[1:5,1:5]
class(dat1);class(dat2);class(dat3)
all(rownames(dat1)==rownames(dat2))
all(rownames(dat1)==rownames(dat3))

## Make the data non-negative by shiftig towards positive direction
if (!all(dat1>=0)) dat1 <- pmax(dat1 + abs(min(dat1)), .Machine$double.eps) # shift the data to make all entries positive
if (!all(dat2>=0)) dat2 <- pmax(dat2 + abs(min(dat2)), .Machine$double.eps)
if (!all(dat3>=0)) dat3 <- pmax(dat3 + abs(min(dat3)), .Machine$double.eps)
dat1 <- dat1/max(dat1)   # Globally rescale data to avoid potential overflow/underflow
dat2 <- dat2/max(dat2)
dat3 <- dat3/max(dat3)
dat <- list(dat1,dat2,dat3)
SS <- c(mean(dat1^2),mean(dat2^2),mean(dat3^2))
SS
weight <- max(SS)/SS
weight

### Integrative clustering is carried out in two steps
### Step 1: Find optimum number of clusters,k
### Step 2: Using optimum k, find the cluster-membership for samples

### Step 1: Find Optimum number of clusters, k
opt.k <- nmf.opt.k(dat=dat,n.runs=30,n.fold=5,k.range=2:8,result=T,wt=weight)
### Step 2: Use optimum k = 3 and find cluster membership
fit <- nmf.mnnals(dat=dat,k=3,maxiter=200,st.count=30,n.ini=30,ini.nndsvd=TRUE,seed=TRUE,wt=weight)

### Assign cluster membership using W
cluster.mem.nmf <- fit$clusters
table(cluster.mem.nmf)
dim(fit$convergence)

# Image plot of consensus matrix
dd <- fit$consensus
dd <- dd[names(sort(cluster.mem.nmf)),names(sort(cluster.mem.nmf))]
aheatmap(dd,col="Greys",Rowv=NA, Colv=NA)

## Convergence check
plot(1:nrow(fit$convergence),fit$convergence[,4],type="l",lwd=2, col="red",main="Convergence",xlab="iter",ylab="Relative error")
abline(h=0,col="blue")

## Cluster membership data
cluster.mem.nmf <- sort(cluster.mem.nmf)
covariates <- data.frame(intNMF.cluster=cluster.mem.nmf)
covariates$intNMF.cluster <- as.factor(covariates$intNMF.cluster)
head(covariates)

## Heatmap
d1 <- t(d1[rownames(covariates),])
d2 <- t(d2[rownames(covariates),])
d3 <- t(d3[rownames(covariates),])
all(rownames(covariates)==colnames(d1))
all(rownames(covariates)==colnames(d2))
all(rownames(covariates)==colnames(d3))

windows(width=12, height=14)
par(mfrow=c(3,1))
hmcol <- colorRampPalette(c("blue","deepskyblue","white","orangered","red3"))(100)
ann.color <- list(NMF.cluster=c("gray30","chartreuse3","deeppink"))
aheatmap(d1,col=hmcol,annCol=covariates,annColors=ann.color,Rowv=F, Colv=NA, labRow=NA, labCol=NA,annLegend=T,legend=T,fontsize=8,
		cexRow=1.2,main="CNV")
aheatmap(d2,col=hmcol,annCol=covariates,annColors=ann.color,Rowv=F, Colv=NA, labRow=NA, labCol=NA,annLegend=T,legend=T,fontsize=8,
		cexRow=1.2,main="Methylation")
aheatmap(d3,col=hmcol,annCol=covariates,annColors=ann.color,Rowv=F, Colv=NA, labRow=NA, labCol=NA,annLegend=T,legend=T,fontsize=8,
		cexRow=1.2,main="Expression")


#this script counts the number of active/elligible participants per month in the study (denominator for events)

# if(!require(rstudioapi)){install.packages("rstudioapi")}
# library(rstudioapi)
# if(!require(rstudioapi)){install.packages("lubridate")}
# library(lubridate)
if(!require(rstudioapi)){install.packages("zoo")}
library(zoo)

#
# projectFolder<-dirname(rstudioapi::getSourceEditorContext()$path)
# setwd(projectFolder)
# setwd('..')
# base_folder<-getwd()

study_population <- readRDS(paste0(populations_dir, "ALL_study_population.rds"))

start.date<-as.Date(study_population$start_follow_up)
end.date<-as.Date(study_population$end_follow_up)

ym1 <- as.yearmon(as.character(start.date), "%Y-%m-%d") # convert to yearmon
ym2 <- as.yearmon(as.character(end.date), "%Y-%m-%d") # ditto

#get the seq of months between start dates and end dates in a list
#easy with a for loop, but better with apply

#start with a loop and then see how slow it is, make more elegant later

FUmonths<-list()

for (i in 1:length(ym1)){
  s <- seq(ym1[i], ym2[i], (1/12)) # create yearmon sequence
  s<-as.numeric(format(s, "%Y%m"))
  FUmonths[[i]]<-s
}

#doesn't take too long

FUmonths<-unlist(FUmonths)
studyFUmonths<-FUmonths[(FUmonths>=200901)&(FUmonths<=201912)]

FUmonths_df<-as.data.frame(table(studyFUmonths))
FUmonths_df$YM<-as.Date(paste0(as.character(FUmonths_df$studyFUmonths),"01"), format="%Y%m%d")
FUmonths_df$YM<-format(as.Date(FUmonths_df$YM),"%Y-%m")

# for plots need to split(FUmonths,by=year)?

saveRDS(data.table(FUmonths_df), paste0(populations_dir, "denominator.rds"))
write.csv(FUmonths_df,paste0(populations_dir, "denominator.csv"))

pdf((paste0(output_dir, "/plots/denominator.pdf")), width=8, height=4)
plot(FUmonths_df$studyFUmonths, FUmonths_df$Freq, ylab="Persons Observed per Month", xlab="Year and Month")
invisible(dev.off())


library(hdfmat)
suppressMessages(library(float))

f = tempfile()
n = "mydata"
type = "float"

nr = 3
nc = 10
x = matrix(1:(nr*nc), nr, nc)

h = hdfmat::hdfmat(f, n, nr, nc, type)
h$fill(x)
alpha = 10
h$scale(alpha)

test = h$read()
truth = float::fl(alpha * x)

stopifnot(all.equal(test, truth))

h$close()
unlink(f)


#'@title calclwl
#'
#'@description Estimate waterline length (\code{lwl}) (m) from length between
#'perpendiculars (\code{lbp}) (m).
#'
#'@param lbp Length between perpendiculars (vector of numericals, m)
#'@param shipType Ship type (vector of strings, see \code{\link{calcShipType}}).
#' Must align with
#'\code{tankerBulkCarrierGCargoShipTypes} and \code{roroPaxShipTypes} groupings
#'@param tankerBulkCarrierGCargoShipTypes Ship types specified in input
#' \code{shipTypes} to be modeled as tankers, bulk carriers and general cargo
#' vessels (vector of strings)
#'@param roroPaxShipTypes Ship types specified in input \code{shipTypes} to be
#'modeled as RORO and passenger ships (vector of strings)
#'
#'@details
#'This method this requires ship types to be grouped. Use the
#' \code{tankerBulkCarrierGCargoShipTypes} and \code{roroPaxShipTypes} grouping
#' parameters to provide these ship type groupings. Any ship types not included
#' in these groupings will be considered as miscellaneous vessels.
#'
#'@return \code{lwl} (vector of numericals, m)
#'
#'@references
#'\href{https://gitlab.gbar.dtu.dk/oceanwave3d/Ship-Desmo}{Kristensen, H. O.
#'"Ship-Desmo-Tool." https://gitlab.gbar.dtu.dk/oceanwave3d/Ship-Desmo}
#'
#'@examples
#'calclwl(c("bulk.carrier","container.ship","cruise"), c(214.5,396,140))
#'
#'@export

calclwl<-function(shipType, lbp,
                  tankerBulkCarrierGCargoShipTypes=c("tanker","general.cargo","chemical.tanker","liquified.gas.tanker","oil.tanker","other.tanker","bulk.carrier"),
                  roroPaxShipTypes=c("ro.ro","passenger","ferry.pax","ferry.ro.pax","cruise","yacht","cruise.ed")
                  ){
  lwl<- ifelse(shipType %in% tankerBulkCarrierGCargoShipTypes,#case 1
               1.02*lbp,
               ifelse(shipType%in%roroPaxShipTypes,#case 2
                      1.035*lbp,
                      1.01*lbp #not in tanker, bulk carrier, general cargo, or passenger
               )#end case1
  )#end case2

  return(lwl)
}


  # clear
  cat("\014")
  rm(list = ls())
  dev.off(dev.list()["RStudioGD"])

  # Libraries
  library(seqinr)
  library(MASS)
  library(ggplot2)
  library(ggpubr)
  library(stringr)
  library(combinat)

  #--------------------- SELECT DATA ---------------------------------------------
  # 'artificial' and 'artificial-non-uni' for artificial dataset, 'real' for real-world data (biom_data_150bp.rda)
  dataset_type <- "real"

  #---------------- FUNCTIONS ----------------------------------------------------

  # Returns prime numbers up to integer n
  sieve <- function(n) {
    n <- as.integer(n)
    if(n > 1e6) stop("n too large")
    primes <- rep(TRUE, n)
    primes[1] <- FALSE
    last.prime <- 2L
    for(i in last.prime:floor(sqrt(n)))
    {
      primes[seq.int(2L*last.prime, n, last.prime)] <- FALSE
      last.prime <- last.prime + min(which(primes[(last.prime+1):n]))
    }
    which(primes)
  }

  # Reads sequence from input file
  seqList <- function(x, type) {
    if (type == "DNA") {
      as.list(read.fasta(x,
                         as.string = TRUE,
                         seqtype="DNA",
                         seqonly = TRUE,
                         strip.desc = TRUE))
    }
    else {
      if (type == "AA") {
        as.list(read.fasta(x,
                           as.string = FALSE,
                           seqtype="AA",
                           seqonly = FALSE,
                           strip.desc = TRUE))
      }
      else {
        NULL
      }
    }
  }

  # Generates random DNA sequences
  createRandomSequencesBasedOnDistr <- function(count, length, prob=c(0.25,0.25,0.25,0.25), fileNameRandSeqs) {

    sink(fileNameRandSeqs)
    for (i in 1:count) {
      cat(">Seq", i, "\n", sep = "")
      seqX <- sample(c("A","C","G","T"), length, rep=TRUE, prob)
      cat(paste(seqX,collapse=""), "\n", sep = "")
    }
    sink()
  }

  # Generating random permutations of godel number assignments
  createRandomSequenceValues <- function(seedList, type) {

    if ( type == "DNA" ) {
      results <- matrix(, nrow = length(seedList), ncol = 4)
    }
    else if ( type == "AA" ) {
      results <- matrix(, nrow = length(seedList), ncol = 23)
    }

    for (i in 1:length(seedList)) {
      if ( type == "DNA" ) {
        results[i,] <- sample(seq(from = 1, to = 4, by = 1), size = 4, replace = FALSE)
      }
      else if ( type == "AA" ) {
        results[i,] <- sample(seq(from = 1, to = 23, by = 1), size = 23, replace = FALSE)
      }
    }
    return(results)
  }

  assignSets <- function(randSequenceValues, type) {

    stringValues <- ""

    if (type == "DNA") {
      #DNA Set
      cat("Sequence Values: (")

      for (i in 1:4) {
        stringValues <- paste(stringValues, randSequenceValues[i], ", ")
      }
      cat(stringValues)
      cat(")\n")
      assign("A", randSequenceValues[1], envir = .GlobalEnv)
      assign("C", randSequenceValues[2], envir = .GlobalEnv)
      assign("G", randSequenceValues[3], envir = .GlobalEnv)
      assign("T", randSequenceValues[4], envir = .GlobalEnv)
    }
    else if ( type == "AA") {
      # AA Set 1
      cat("Sequence Values: (")
      for (i in 1:23) {
        stringValues <- paste(stringValues, randSequenceValues[i], ", ")
      }
      cat(stringValues)
      cat(")\n")
      assign("A", randSequenceValues[1], envir = .GlobalEnv) # alanine, ala
      assign("R", randSequenceValues[2], envir = .GlobalEnv) # arginine, arg
      assign("N", randSequenceValues[3], envir = .GlobalEnv) # asparagine, asn
      assign("D", randSequenceValues[4], envir = .GlobalEnv) # aspartic acid, asp
      assign("B", randSequenceValues[5], envir = .GlobalEnv) # sparagine or aspartic acid, asx
      assign("C", randSequenceValues[6], envir = .GlobalEnv) # cysteine, cys
      assign("E", randSequenceValues[7], envir = .GlobalEnv) # glutamic acid, glu
      assign("Q", randSequenceValues[8], envir = .GlobalEnv) # glutamine, gln
      assign("Z", randSequenceValues[9], envir = .GlobalEnv) # glutamine or glutamic acid, glx
      assign("G", randSequenceValues[10], envir = .GlobalEnv) # glycine, gly
      assign("H", randSequenceValues[11], envir = .GlobalEnv) # histidine, his
      assign("I", randSequenceValues[12], envir = .GlobalEnv) # isoleucine, ile
      assign("L", randSequenceValues[13], envir = .GlobalEnv) # leucine, leu
      assign("K", randSequenceValues[14], envir = .GlobalEnv) # lysine, lys
      assign("M", randSequenceValues[15], envir = .GlobalEnv) # methionine, met
      assign("F", randSequenceValues[16], envir = .GlobalEnv) # phenylalanine, phe
      assign("P", randSequenceValues[17], envir = .GlobalEnv) # proline, pro
      assign("S", randSequenceValues[18], envir = .GlobalEnv) # serine, ser
      assign("T", randSequenceValues[19], envir = .GlobalEnv) # threonine, thr
      assign("W", randSequenceValues[20], envir = .GlobalEnv) # tryptophan, trp
      assign("Y", randSequenceValues[21], envir = .GlobalEnv) # tyrosine, tyr
      assign("V", randSequenceValues[22], envir = .GlobalEnv) # valine, val
      assign("X", randSequenceValues[23], envir = .GlobalEnv) # undetermined
    }

    stringValues
  }

  # Statistics function
  godelStatistics <- function(x) {

    if (logOutput) {
      cat(paste("  Min  : ", summary(x)[1], "\n"))
      cat(paste("1st Qu.: ", summary(x)[2], "\n"))
      cat(paste("Median : ", summary(x)[3], "\n"))
      cat(paste(" Mean  : ", summary(x)[4], "\n"))
      cat(paste("3rd Qu.: ", summary(x)[5], "\n"))
      cat(paste("  Max  : ", summary(x)[6], "\n"))
      cat(paste("St. Dev: ", sd(x), "\n"))
    }

    results <- list(minG = summary(x)[1], firstQG = summary(x)[2],
         medianG = summary(x)[3], meanG = summary(x)[4],
         thirdQG = summary(x)[5], maxG = summary(x)[6],
         stdG = sd(x))

    return(results)
  }

  calculateGodelNumbers <- function(sequences, primes, encoding){

    chars = str_split(sequences, "", simplify = TRUE)

    chars.enc = matrix(data = 0, nrow = nrow(chars), ncol = ncol(chars))

    chars.enc = chars.enc + (chars == "A") * encoding[1]
    chars.enc = chars.enc + (chars == "C") * encoding[2]
    chars.enc = chars.enc + (chars == "G") * encoding[3]
    chars.enc = chars.enc + (chars == "T") * encoding[4]

    primes = log(primes)

    chars.enc = chars.enc %*% diag(primes)
    godel_nums <- rowSums(chars.enc) # gn_new
    return(godel_nums)

  }

  #----------------------------- Main code ---------------------------------------
  primes <- sieve(20000)            # length of primes should be >= max sequence length
  logOutput <- FALSE                # debug output
  replicate <- TRUE                 # if we need to set specific seed numbers
  type <- "DNA"                     # type of data

  # encodings
  encodings <- permn(c(1,2,3,4))
  numberOfEncodings <- 24;              # number of different assignments of letters for Godel numbers (we have DNA data)

  # The following values should execute within 6 minutes with a good enough resolution
  seqLengthLimit <- 150
  numberOfArtificialSeqs <- 90000     # "A","C","G","T"

  # Creating artificial data set
  # createRandomSequencesBasedOnDistr(numberOfArtificialSeqs, seqLengthLimit, c(0.3,0.3,0.2,0.2), "data/artificialSeq-non-unis.fasta")

  # Loading a fasta file - artificial dataset
  if (dataset_type == "artificial"){
    ompGene.list <- seqList("data/artificialSeqs.fasta", type)
    ompGene.list.raw <- ompGene.list
  } else if (dataset_type == "real"){
    ompGene.list <- seqList("data/realSeqs_biom_150bp.fasta", type)
  } else if (dataset_type == "artificial-non-uni"){
    ompGene.list <- seqList("data/artificialSeq-non-unis.fasta", type)
  } else {
    print("Incorrect dataset type.")
  }
  sequences <- unlist(ompGene.list)

  #encodingValues <- createRandomSequenceValues(seedValuesList, type) - we don't neet this function
  encodingValues <- matrix(0, nrow = length(encodings), ncol = 4)
  for (i in 1:nrow(encodingValues)){
    encodingValues[i,] <- encodings[[i]]
  }

  sizeExp <- length(ompGene.list)
  selectedSequences <- c(1:sizeExp)

  godelValuePoints <- data.frame(matrix(0, ncol = numberOfEncodings, nrow = sizeExp))
  namesList <- list()
  for (i in 1:numberOfEncodings) {
    namesList[i] <- paste('godel_log_pos', i, sep = '')
  }
  godelValuePoints <- setNames(godelValuePoints, namesList)
  godelValuePoints$seqNames <- unlist(attributes(ompGene.list)$name)

  stringAssignValues <- vector(mode="character", length=numberOfEncodings)

  len_of_sequences <- str_length(sequences[1])
  primes <- primes[1:len_of_sequences]
  primes <- as.numeric(primes)

  # main loop - godel number calculation
  for (indexPos in 1:numberOfEncodings) {

    stringAssignValues[indexPos] <- assignSets(encodingValues[indexPos,], type)
    encoding <- encodingValues[indexPos,]
    godelValuePoints[, paste('godel_log_pos', indexPos, sep = '')] <- calculateGodelNumbers(sequences, primes, encoding)

  }

  statsPos <- data.frame(matrix(0, ncol = 7, nrow = numberOfEncodings))
  statsPos <- setNames(statsPos, c("minG", "firstQG", "medianG", "meanG", "thirdQG", "maxG", "stdG"))
  for (indexPos in 1:numberOfEncodings) {
    statsPos[indexPos, ] <- godelStatistics(godelValuePoints[, paste('godel_log_pos', indexPos, sep = '')])
  }

  statsPos_rownames <- c()
  for (i in 1:numberOfEncodings){
    this_enc <- paste(encodingValues[i,], collapse = '')
    statsPos_rownames <- c(statsPos_rownames, paste("enc_", this_enc, sep = ''))
  }

  rownames(statsPos) <- statsPos_rownames

  # Theoretical distribution parameters
  P1 <- sum(log(primes[1:seqLengthLimit]))
  P2 <- sum((log(primes[1:seqLengthLimit]))^2)
  theoreticalMeanEqual <- P1*2.5
  theoreticalStdEqual <- sqrt(P2*1.25)
  theoretical_dist <- rnorm(90000, theoreticalMeanEqual, theoreticalStdEqual)

  # comparisons
  para <- matrix(nrow=numberOfEncodings, ncol = 2)
  for (indexPos in 1:numberOfEncodings) {
    fit <- fitdistr(godelValuePoints[, indexPos], "normal")
    para[indexPos, 1] <- fit$estimate["mean"]
    para[indexPos, 2] <- fit$estimate["sd"]
  }

  statsPos$stringAssignValues <- as.factor(stringAssignValues)
  statsPos$fit_estimate <- ((para[,1]-theoreticalMeanEqual)/para[,1])*100
  statsPos$fit_sd <- ((para[,2]-theoreticalStdEqual)/para[,2])*100

  statsPos$theoretical_mean <- theoreticalMeanEqual
  statsPos$theoretical_std <-theoreticalStdEqual

  # t-test
  statsPos$p.value <- NaN
  for (i in 1:numberOfEncodings){
    t_test_results <- t.test(godelValuePoints[,i], theoretical_dist)
    statsPos[i,]$p.value <- t_test_results$p.value
  }

  #-------------------- Main histogram plotting ----------------------------------
  dir.create('plots')
  indexPos = 1 # Specify which encoding to plot
  binwidthPlot = 5
  this_enc <- paste(encodingValues[indexPos,], collapse = '')

  # comparisons file save
  filepath <- paste('plots/comparisons_',dataset_type, '.csv', sep = '' )
  write.csv(as.data.frame(statsPos), file = filepath)

  this_title= expression(paste('Histogram and Density plot of ln(Godel numbers) - encoding 1234', sep = '' ))

  # Plots
  filepath <- paste('plots/histogram_encoding_', this_enc,'_',dataset_type, '.png', sep = '' )
  png(file = filepath, width=1200, height=800)
  my_plot <- ggplot(godelValuePoints, aes(x=godelValuePoints[, indexPos]), environment = environment()) +
    geom_histogram(aes(y=..density..), colour="black", fill="white", binwidth=binwidthPlot)+
    geom_density(alpha=.2, fill="#FF6666") +
    stat_function(fun = dnorm, args = list(mean = theoreticalMeanEqual, sd = theoreticalStdEqual), color = "darkblue", size = 1, linetype = "longdash") +
    stat_function(fun = dnorm, args = list(mean = para[indexPos,1], sd = para[indexPos,2]), color = "darkred", size = 2, linetype = "dotdash") +
    labs(title = this_title, x=expression('ln(Godel Numbers)'), y = "Density")+
    xlim(1000,3000) +
    ylim(0, 0.009) +
    scale_color_brewer(palette="Accent") +
    theme(title  = element_text(size=20),
          axis.text.x = element_text(size = 20, face = 'bold'), axis.text.y = element_text(size = 15),
          axis.title.x =  element_text(size=20))
  print(my_plot)

  dev.off()

  # ---------------- Other plots -------------------------------------------------

  p1 <- ggplot(statsPos, aes(x = reorder(stringAssignValues, fit_estimate), y = fit_estimate, group=1)) +
    geom_point() +
    geom_line() +
    theme(axis.text.x = element_text(angle = 90, hjust = 1)) +
    labs(title= "Difference between theoretical and observed value of Mean (%)",x="Assignments", y = "Difference in mean (%)")

  p2 <- ggplot(statsPos, aes(x = reorder(stringAssignValues, fit_estimate), y = fit_sd, group=1)) +
    geom_point() +
    geom_line() +
    theme(axis.text.x = element_text(angle = 90, hjust = 1)) +
    labs(title= "Difference between theoretical and observed value of standard deviation (%)",x="Assignments", y = "Difference in  standard deviation (%)")

  ggarrange(p1 + rremove("x.text"), p2,
            labels = c("A", "B"),
            ncol = 1, nrow = 2)

  # a t g c
  lapply(which(statsPos$maxG == min(statsPos$maxG)),
         function(x) assignSets(encodingValues[x,], "DNA"))
  # artificial dataset: 4 , 1 , 3 , 2 (min of meanG)
  # artificial dataset: 4 , 2 , 1 , 3 (min of minG)
  # artificial dataset: 2 , 1 , 3 , 4 (min of maxG)

  # a t g c
  lapply(which(statsPos$maxG == max(statsPos$maxG)),
         function(x) assignSets(encodingValues[x,], "DNA"))
  # artificial dataset: 1 , 4 , 2 , 3 (max of meanG)
  # artificial dataset: 4 , 3 , 2 , 1 (max of minG)
  # artificial dataset: 1 , 3 , 4 , 2 (max of maxG)


#' UTCI
#'
#' Calculate Universal Thermal Climate Index (UTCI) index.
#'
#' @param numeric t Air temperature in Celsius degrees.
#' @param numeric rh Air Relative humidity in percentage.
#' @param numeric wind Wind speed in meter per second.
#' @param numeric tr Mean radiant temperature in Celsius Degrees
#' @return UTCI
#'
#'
#' @author  Istituto di Biometeorologia Firenze Italy  Alfonso Crisci \email{a.crisci@@ibimet.cnr.it}
#' @keywords  UTCI
#' @references Bröde P,Jendritzky G,Fiala D and Havenith G, (2011),
#' The Universal Thermal Climate Index UTCI in Operational Use,  International Journal of Biometeorology
#' \url{http://www.utci.org/isb/documents/windsor_vers05.pdf}
#' @export
#'
#'
#'
#'
utci <- function(t, rh, wind, tr) {
     tmrt=tr;
    .Call('biometeoR_utci', PACKAGE = 'biometeoR', t, rh, wind, tmrt)
}


library(tidyverse)
library(dplyr)
library(tidyr)
library(ggplot2)
library(sf)
library(statar)
library(USAboundaries)
library(leaflet)
library(geofacet)
library(RColorBrewer)
#install.packages('geofacet')

#Q1. how many children were remove in the year of 2019 by state?
#Q2. were children removed because of socioeconomics or abused?
#Q3. is there a difference between races and wait time in adoption?

#https://www.statology.org/conditional-mutating-r/
child_data <- read.csv ("/Users/ashleyrabanales/Desktop/STAT 4210 - Regression/Data Sets/FC2019v1.csv")
head(child_data)#checking if imported correctly

#creating a new vari for race/enthnicity

child <- child_data %>%
  mutate (race_ethnicity =
            case_when(amiakn == 'Yes' ~ 'American Indian or Alaska Native',
              asian == 'Yes' ~ 'Asian',
              blkafram == 'Yes' ~ 'Black/African American',
              hawaiipi == 'Yes' ~ 'Hawaiian or Other Pacific Islander',
              white == 'Yes'~ 'White',
              hisorgin == 'Yes' ~ 'Hispanic'))

# Drop incomplete values in race
child = child[!child$race_ethnicity=="",]
child = child[complete.cases(child$race_ethnicity),]

head(child$race_ethnicity) # check if it came out correctly

#checking which has the highest abusement
tab(child, phyabuse)#Yes:  12.12  NA: 4.76
tab(child, sexabuse) #Yes:  3.82  NA: 4.76
tab(child, neglect) #Yes:  62.42  NA: 4.76 ######
tab(child, aaparent)#low Yes:  5.27  NA: 4.76
tab(child, daparent)#high Yes:  33.99  NA: 4.76 ####
tab(child, aachild) #low Yes:  0.33  NA: 5.19
tab(child, dachild) #low Yes: 1.96 NA: 4.76

#creating new variable for all abuse
child <- child %>%
  mutate (removal_abuse =
            case_when(phyabuse == 'Yes' ~ 'Physical Abuse', #Removal Reason-Physical Abuse
              sexabuse == 'Yes' ~ 'Sexual Abuse',
              neglect  == 'Yes' ~ 'Neglect',
              aaparent == 'Yes' ~ 'AA Parent',
              daparent == 'Yes'~ 'DA Parent',
              aachild == '1' ~ 'AA Child',
              dachild == "Yes" ~ 'DA Child'))

# Drop incomplete values in abuse
child = child[!child$removal_abuse=="",]
child = child[complete.cases(child$removal_abuse),]

print(child$removal_abuse)
#omitted 470435 entries  were NA's

# Generate wait time variable
child$wait_time <- as.Date(as.character(child$cursetdt), format="%Y-%m-%d") -
as.Date(as.character(child$latremdt), format="%Y-%m-%d")
child$wait_time <- as.numeric(child$wait_time)

###REGRESSION
#set child age as a numeric variable
child$ageatstart <- as.numeric(child$ageatstart)
# Some children are scheduled for foster care even before they are born.
# In this case, wait time will be negative value, so we need to clean it
child = child[!child$wait_time <0,]
# Some children run away. In this case, wait time will be 0.
# We need to drop those cases.
tab(child, curplset) # There are 9963 children who are missing or ran away
child = child[!child$curplset=="Missing",]
child = child[!child$curplset=="Runaway",]
child = child[!child$curplset == "NA",]

# Drop incomplete NA values in race / abuse
child = child[!child$race_ethnicity=="",]
child = child[!child$neglect=="",]

# Drop incomplete values in sex
child = child[!child$sex=="",]

# Run regression model
regression_model <- lm(wait_time ~ race_ethnicity + sex + removal_abuse, data=child)
print(summary(regression_model))

###################BARPLOT
#library(RColorBrewer)
#ageatstart, st, totalrem

  child_2 <- child %>%
  group_by(sex, wait_time, curplset, race_ethnicity, ageatstart, ageadopt, removal_abuse) %>%
  summarize(rem1dt = length(2019))
str_sub(child_2$rem1dt, 1,4) = '2019'

ggplot(data = child_2) +
  geom_bar(mapping = aes(x = curplset, fill = race_ethnicity)) +
  scale_fill_brewer(palette="Pastel1") +
  labs(x = "Placement Setting",
       y = "Wait Time",
       title = "Figure 1: Current Placement Setting", fill = "Race/Ethnicity",
       subtitle = "Wait Time By Race/Enthicity, 2019") +
  theme(strip.text.y = element_text(
    size = 15, face = "times.new.roman"
  )) +
theme_bw() + theme(axis.text.x = element_text(angle = 45, hjust=1)) +
  theme(plot.title = element_text(face="bold", size=14
  )) +  theme(plot.subtitle = element_text(face="bold", size=14))

ggsave(filename = "figure1_curplset_race_sex.png", width = 8, height = 5)

##############
#summary of stats
#remember to remove children who went missing and runaway
#child_2 = child_2[!child_2$wait_time <0,]

#ggplot(data = child_2) +
 # stat_summary(
    mapping = aes(x = race_ethnicity, y = wait_time),
    fun.min = min,
    fun.max = max,
    fun = median,
    cex=0.5
  #) + theme(axis.text.x = element_text(angle = 45, hjust=1)) +
  #labs(x = "Race",
 # y = "Wait Time",
#title = "Figure 2: Statistics Summary of",
#subtitle = "Wait Time By Race, 2019",
#xlab= "Variable Lable", ylab="density",) +
 # theme(plot.title = element_text(face="bold", size=18,
 #                 )) +
 # theme(plot.subtitle = element_text(face="bold", size=18,))

#ggsave(filename = "figure2_statsum.png", width = 6, height = 4)

#####HISTOGRAM###
library(RColorBrewer)
#removing Nas
#child_2 = child_2[!child_2$removal_abuse=="",]
child_2 = child_2[complete.cases(child_2$removal_abuse),]
#removing sex na's
child_2 = child_2[!child_2$sex=="",]
child_2 = child_2[complete.cases(child_2$sex),]

ggplot(data = child_2, mapping = aes(x= removal_abuse , fill = sex)) +
  geom_bar(position = "dodge") +
  scale_fill_brewer(palette = "Pastel1") +
  labs(x = "Type of Abuse",
       y = "Count",
       legend = "Sex",
       title = "Figure 2: Type of Abusement Removal",
       subtitle = "by Sex, 2019") +
theme_bw() + theme(axis.text.x = element_text(angle = 45, hjust=1)) +
  theme(plot.title = element_text(face="bold", size=14
  )) +  theme(plot.subtitle = element_text(face="bold", size=14))

ggsave(filename = "figure3_type_of_abusement.png", width = 6, height = 4)

#####MOSAIC PLOT################

install.packages("ggmosaic")
library(ggmosaic)
library(ggplot2)

#child$Waited_Over_Year <- ifelse(child$wait_time > 365, c("yes"), c("no"))

mosaic_examp <- ggplot(data = child_2) +
  geom_mosaic(aes(x = product(removal_abuse), fill =curplset)) +
    labs (y="Placement", x="Abusement", fill = "Current Placement", title = "Figure 3: Mosaic Plot of",
          subtitle = "Placement Setting and Type of Abuse, 2019") +
theme(plot.title = element_text(face="bold", size=14,)) +
  theme(plot.subtitle = element_text(face="bold", size=14,)) +
  theme(axis.text.x = element_text(angle = 45, hjust = 1))
mosaic_examp

ggsave(filename = "figure4_mosaic.png", width = 8, height = 4)

##wanted to perform a lingustic regression
## Read in Grad School Admit Data ##

#gs <- readr::read_csv("binary.csv")

## Integrity Check ##

summary(child)
str(child)

## Since "rank" is technically a categorical variable (rank "1" means high prestige
## undergrad school,rank "4" means lowest prestige) let's make sure we have a
## reasonable amount of 0's and 1' for admit within each level of rank

table(gs$admit,gs$rank)
table(gs$admit)

## Okay, it looks like we won't have a problem with imbalanced class sizes ##

## Let's go ahead and fit our logistic regression model ##

child$neglect <- factor(child$neglect)

gs$rank1 <- relevel(gs$rank,ref="4") #set rank 4 as baseline rank
## creating a new column

## logistic regression
lmod <- glm(neglect ~ race + wait_time , data = child, family = "binomial")

##glm stands for generalized linear model

## Despite Logistic Regression not having quite as restrictive assumptions
## as linear, we still have to make sure we don't have too much multicollinearity ##

## variance inflation factor
car::vif(lmod)

## Okay, great! Let's check out the summary of our model ##

summary(lmod)

## We can build an ROC curve to assess the predictive capability of the model ##

my_roc <- ROSE::roc.curve(lmod$y,fitted(lmod),plotit = T)
## ROSE::roc.curve(model$y, fitted(model), plot yes/no)
my_roc

## While Logistic Regression doesn't estimate coefficients using sums of squares,
## we can still obtain a pseudo-R^2 value ##

DescTools::PseudoR2(lmod,which="McKelveyZavoina")

## The summary output gives gross output like from last week. Using the broom package,
## we can tidy this up ##

lmod %>%
  broom::tidy(conf.int=T,exponentiate=T)

exp(lmod$coefficients) #untransforming coefficients
## exp stands for e^

## Because the exponentiated coefficients are standardized values, this would be
## a great application of the confidence interval plot generated last week ##

##Intrepreting gpa
## As gpa increase by 1 point, the odds of admissions into grad school increase
## by 123%

# 2.23 - 1*100= 123%

p <- lmod %>%
  broom::tidy(conf.int=T,exponentiate=T) %>%
  dplyr::mutate(Sig = if_else(p.value < 0.05,"Significant",
                              "Non-Significant")) %>%
  ggplot(aes(x=term,y=estimate)) +
  geom_errorbar(aes(ymin=conf.low,ymax=conf.high,color=factor(Sig)),width=0.1) +
  geom_point(aes(color=factor(Sig))) +
  geom_hline(aes(yintercept = 1),color="black",linetype="dashed") +
  labs(x = "Variable",
       y = "Estimated Exponentiated Coefficient",
       color = "Statistical \n Significance") +
  theme_classic() + coord_flip() +
  ggtitle("Confidence Intervals for Logistic Regression Analysis") +
  theme(plot.title = element_text(hjust=0.5))

library(plotly)
plotly::ggplotly(p)

## Another useful graph might be one of the predicted probabilities.
## Here, let's say, for a fixed value of UG GPA (3.5), we want to see
## how the predicted probability of admission differs across GRE scores as well as
## between prestige of undergraduate institution.

new_gs1 <- tibble(gpa = rep(3.5,100), #repeats 3.5 100 times
                  rank1 = rep(1,100), #repeats 1 100 times
                  gre = seq(200,800,length.out = 100)) #sequence of GRE scores
## creates fake data
## column names of fake data must be same as real data column names

new_gs2 <- tibble(gpa = rep(3.5,100),
                  rank1 = rep(2,100), #rank is at rank 2
                  gre = seq(200,800,length.out = 100))

new_gs3 <- tibble(gpa = rep(3.5,100),
                  rank1 = rep(3,100),
                  gre = seq(200,800,length.out = 100))

new_gs4 <- tibble(gpa = rep(3.5,100),
                  rank1 = rep(4,100),
                  gre = seq(200,800,length.out = 100))

new_gs <- dplyr::bind_rows(new_gs1,new_gs2,new_gs3,new_gs4)
#bind 4 datasets together

new_gs$rank1 <- factor(new_gs$rank1) #changes rank to be categorical

new_gs$probs <- predict.glm(lmod,newdata=new_gs,type="response")
## predict.glm gives predictions based on data and linear model
## type = response gives predicted probabilities

new_gs

new_gs %>%
  ggplot(aes(x=gre,y=probs)) + #specify x and y axes
  geom_line(aes(color=rank1)) + labs(x = "GRE Scores",
                                     y = "Predicted Probability of Admission",
                                     color = "Undergraduate School \n Prestige") +
  theme_classic() + ggtitle("Predicted Probability of Graduate School Admission",
                            subtitle = "for fixed Undergraduate GPA of 3.5") +
  theme(plot.title=element_text(hjust=0.50),
        plot.subtitle=element_text(hjust=0.50))

## Model Validation ##

set.seed(12345)

## Split up gs into a training and testing set ##

####
samp <- sample(c("train","test"), nrow(gs), replace = T, prob = c(.7, .3))

#samp <- sample(c(TRUE,FALSE),nrow(gs),replace=T,prob=c(0.70,0.30))
# sample(vector to sample from, how many times to sample,
## replace yes/no, probabilities associated with each value in vector)
## we want about 70% of data in training set, 30% in test

samp

gs_train <- gs[samp == "train",] #only keep rows where samp = train

gs_test <- gs[samp == "test",] #only keep rows where samp = test

## Build Model using Training Set ##

tmod <- glm(admit ~ gre + gpa + rank1, data = gs_train, family = "binomial")

## Assess VIF ##

car::vif(tmod)

## ROC curve ##

ROSE::roc.curve(tmod$y,fitted(tmod),plotit = T)

## Okay, so the training model has a lot of the same characteristics as the
## traditional approach we have seen previously. So now, how do we assess
## classification accuracy? ##

## First, obtain predicted probabilities for testing set ##

gs_test$pred_probs <- predict.glm(tmod,newdata=gs_test,type="response")

## Let's say that a probability of > 0.50 indicates a successful admission and
## < 0.50 is an unsuccessful admission ##

my_table <- table(gs_test$admit,gs_test$pred_probs > 0.50)
addmargins(my_table)

## Specificity ##
## proportion of true negatives that were classified as negative

pt <- table(gs_test$admit,gs_test$pred_probs > 0.50)

pt[1,1]/sum(pt[1,])

##first row, first column / first row total
## gives specificity
## 82/87

## This means we are 94.25% accurate in predicting unsuccessful admissions ##

## Sensitivity ##
## proportion of true positives that were classified as positive

pt[2,2]/sum(pt[2,])

## This means we're not so good at detecting successful admissions ##

## Optional ##
## However, the cut off point of 0.50, while commonly used and logical,
## is arbitrarily chosen. How do we choose a cut off point that well
## categorizes our observations?? ##

cp <- seq(0.50,0.95,by=0.01) #potential cutoff values
sn <- vector("double",length(cp)) #sensitivity
sp <- vector("double",length(cp)) #specificity

for(i in 1:length(cp)){

  tab <- table(gs_test$admit,gs_test$pred_probs > cp[i])

  sp[i] <- ifelse(dim(tab)[2] == 1,0,tab[1,1]/sum(tab[1,]))

  sn[i] <- ifelse(dim(tab)[2] == 1,0,tab[2,2]/sum(tab[2,]))

}

p <- ggplot() +
  geom_line(aes(x = cp, y = sn),color='blue') + #sensitivity in blue
  geom_line(aes(x = cp, y = sp),color='red') + #specificity in red
  theme_classic() + labs(x = "Cut Points",
                         y = "Probabilities") +
  scale_x_continuous(breaks = seq(0.50,0.90,by=0.05))

p

plotly::ggplotly(p)
## We want to choose a cut point such that sensitivity & specificity are maximized ##

## To me this looks like around 0.52 ##

## Let's try it ##

table(gs_test$admit,gs_test$pred_probs > 0.52) %>%
  prop.table()

pt <- table(gs_test$admit,gs_test$pred_probs > 0.52)

## Sensitivity ##

pt[1,1]/sum(pt[1,])

## Specificity ##

pt[2,2]/sum(pt[2,])


 ZGBSVX Example Program Results

 Solution(s)
                    1                 2
 1  (-3.0000, 2.0000) ( 1.0000, 6.0000)
 2  ( 1.0000,-7.0000) (-7.0000,-4.0000)
 3  (-5.0000, 4.0000) ( 3.0000, 5.0000)
 4  ( 6.0000,-8.0000) (-8.0000, 2.0000)

 Backward errors (machine-dependent)
       2.7E-17    6.7E-17

 Estimated forward error bounds (machine-dependent)
       3.5E-14    4.3E-14

 Estimate of reciprocal condition number
       9.6E-03

 A has not been equilibrated

 Estimate of reciprocal pivot growth factor
       1.0E+00


# 4. faza: Napredna analiza podatkov

source("lib/obrisi.r")
source("lib/hc.kolena.R")
source("lib/diagram.obrisi.r")
source("lib/diagram.skupine.R")

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

# Branje podatkov za napredno analizo

tabela = read_csv(
  "podatki/tabela.csv",
  locale = locale(encoding = "Windows-1250"),
  col_types = cols(
    .default = col_guess()
  )
) %>% dplyr::select(-1)

tabela <- tabela %>% mutate(st.poskodovanih.na.10000.preb = stevilo.poskodovanih / prebivalci * 10000,
                             st.nesrec.na.10000.preb = stevilo.nesrec / prebivalci * 10000,
                             st.nesrec.na.1000.vozil = stevilo.nesrec / stevilo.vozil * 1000)

tabela1 <- tabela %>%
  filter(regija != "SLOVENIJA", leto != 2007) %>%
  mutate(
    indeks.rasti.nesrec = stevilo.nesrec - lag(stevilo.nesrec),
    indeks.rasti.poskodovanih = stevilo.poskodovanih - lag(stevilo.poskodovanih)
  )
tabela1$regija <- as.factor(tabela1$regija)

tabela2 <- tabela %>%
  filter(regija != "SLOVENIJA", leto == 2019) %>%
  mutate(
    indeks.rasti.nesrec = stevilo.nesrec - lag(stevilo.nesrec),
    indeks.rasti.poskodovanih = stevilo.poskodovanih - lag(stevilo.poskodovanih)
  ) %>%
  dplyr::select(regija, st.nesrec.na.10000.preb)
tabela2$regija <- as.factor(tabela2$regija)

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

Slovenija <- uvozi.zemljevid("http://biogeo.ucdavis.edu/data/gadm2.8/shp/SVN_adm_shp.zip",
                             "SVN_adm1", encoding="UTF-8") %>% fortify()
Slovenija$NAME_1 <- gsub('Notranjsko-kraška', 'Primorsko-notranjska', Slovenija$NAME_1)
Slovenija$NAME_1 <- gsub('Spodnjeposavska', 'Posavska', Slovenija$NAME_1)

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

# Linearna regresija

g <- ggplot(tabela1, aes(x=stevilo.nesrec, y=stevilo.vozil)) + geom_point()
print(g)

lin.regresija <- g + geom_smooth(method="lm", formula = y ~ x)

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

# Metoda voditeljev

tabela2.norm <- tabela2 %>% dplyr::select(-regija) %>% scale()
rownames(tabela2.norm) <- tabela2$regija
k <- kmeans(tabela2.norm, 3, nstart = 1000)

head(k$cluster, n=12)
table(k$cluster)

k$tot.withinss

skupine <- data.frame(regija=tabela2$regija, skupina=factor(k$cluster))

# Skupine za regije:
# Pomurska                  2
# Podravska                 1
# Koroška                   2
# Savinjska                 1
# Zasavska                  3
# Posavska                  3
# Jugovzhodna Slovenija     2
# Osrednjeslovenska         1
# Gorenjska                 1
# Primorsko-notranjska      2
# Goriška                   2
# Obalno-kraška             1

################################################################################
# Metoda iz predavanj

regije <- tabela2[, 1] %>% unlist()
razdalje <- tabela2[, -1] %>% dist()
dendrogram <- razdalje %>% hclust(method = "ward.D")

# Dendrogram razdalj med regijami glede na podatke o številu nesreč

plot(
  dendrogram,
  labels = regije,
  xlab = "regija",
  ylab = "višina",
  main = "Wardova razdalja med regijami"
)

# Metoda voditeljev

skupine2 = tabela2[, -1] %>%
  kmeans(centers = 3) %>%
  getElement("cluster") %>%
  as.ordered()

r.hc <- tabela2[, -1] %>% obrisi(hc = TRUE)

# Kolena

dendrogram %>%
  hc.kolena() %>%
  diagram.kolena()
# Kolena : 2, 3, 4, 6, 8

# Obrisi

regije.x.y <-
  as_tibble(razdalje %>% cmdscale(k = 2)) %>%
  bind_cols(regije) %>%
  dplyr::select(regija = ...3, x = V1, y = V2)

# Razdelimo regije na 4 skupine

k <- obrisi.k(r.hc)
skupine2 <- tabela2[, -1] %>%
  dist() %>%
  hclust(method = "ward.D") %>%
  cutree(k = k) %>%
  as.ordered()
diagram.skupine(regije.x.y, regije.x.y$regija, skupine2, k)

# Razdelimo regije na 3 skupine

set.seed(20) # ponovljivost rezultatov
skupine2 <- tabela2[, -1] %>%
  kmeans(centers = 3) %>%
  getElement("cluster") %>%
  as.ordered()

skupina.treh <- diagram.skupine(regije.x.y, regije.x.y$regija, skupine2, k)

################################################################################
# Napovedovanje
#-------------------------------------------------------------------------------
# Priprava:

lin <- lm(data = tabela, stevilo.nesrec ~ prebivalci)
g <- ggplot(tabela, aes(x=prebivalci, y=stevilo.nesrec)) + geom_point()
#-------------------------------------------------------------------------------

# Prileganje z zlepki:

z <- lowess(tabela$prebivalci, tabela$stevilo.nesrec)
g + geom_line(data=as.data.frame(z), aes(x=x, y=y), color="green")
#-------------------------------------------------------------------------------

# Model:
# Iz tega modela lahko delamo tudi napovedi.

mls <- loess(data=tabela, stevilo.nesrec ~ prebivalci)
napovedni.model <- g + geom_smooth(method="loess")

# napovedi <- predict(mls, data.frame(prebivalci=seq(1000, 800000, 2000000)))

# g + geom_line(data = data.frame(prebivalci=seq(1000, 800000, 2000000), napovedi = napovedi),
#               aes(x = prebivalci, y = napovedi), col = "blue")
#-------------------------------------------------------------------------------

# Kvadratne napake:

sapply(list(lin, mls), function(x) mean((x$residuals^2)))
# Vrne nam: 1390918, 1132940


library(ppcor)
library(lsa)

args = commandArgs(TRUE)
run_corr <- function(Expr, pcor_type = c('pcor', 'spcor', 'cosine'), method, output){

  if(pcor_type == 'pcor'){
    method = c("pearson", "kendall", "spearman")
    tmp = pcor(t(Expr), method)
    cc = tmp$estimate
    cc[tmp$p.value > 0.05] = 0
  }
  else if(pcor_type == 'spcor'){
    method = c("pearson", "kendall", "spearman")
    tmp = spcor(t(Expr), method)
    cc = tmp$estimate
    cc[tmp$p.value > 0.05] = 0
  }

  else{
    cc = cosine(as.matrix(t(Expr)))
  }
  colnames(cc) = rownames(Expr)
  rownames(cc) = rownames(Expr)
  cc[lower.tri(cc, diag = TRUE)] = NA
  cc = as.data.frame(as.table(cc))
  cc = na.omit(cc)
  colnames(cc) = c('source', 'target', 'weight')
  write.table(cc, output, row.names = F, quote = F, sep = '\t', col.name = F)
}

Expr = read.csv(args[1], sep ='\t', header = T, row.names = 1)
run_corr(Expr, pcor_type = 'pcor', method = 'pearson', output = 'links.txt')


library(data.table)
#library(psych)
setwd("C:\\Users\\Lenovo\\Desktop\\IIIT-Delhi\\semester 7\\IP_LOGS\\WhileDriving")
accel <- read.csv("N1.csv", stringsAsFactors=F)
#head(accel)
summary(accel$val)
plot(accel$val, t="l") # t="l" means line plot

#describe(accel$val)
accel <- read.csv("N2.csv", stringsAsFactors=F)
summary(accel$val)
plot(accel$val, t="l")
accel <- read.csv("N3.csv", stringsAsFactors=F)
summary(accel$val)
plot(accel$val, t="l")
accel <- read.csv("N4.csv", stringsAsFactors=F)
summary(accel$val)
plot(accel$val, t="l")
accel <- read.csv("N5.csv", stringsAsFactors=F)
summary(accel$val)
plot(accel$val, t="l")
#head(accel)
#summary(accel$val)
## t="l" means line plot

#mad and median
library(data.table)
setwd("C:\\Users\\Lenovo\\Desktop\\IIIT-Delhi\\semester 7\\IP_LOGS\\WhileNotDriving")
accel <- read.csv("N1.csv", stringsAsFactors=F)
summary(accel$val)
plot(accel$val, t="l")
accel <- read.csv("N2.csv", stringsAsFactors=F)
summary(accel$val)
plot(accel$val, t="l")
accel <- read.csv("N3.csv", stringsAsFactors=F)
summary(accel$val)
plot(accel$val, t="l")

library(data.table)
library(zoo)
library(stats)
setwd("C:\\Users\\Lenovo\\Desktop\\IIIT-Delhi\\semester 7\\IP_LOGS\\WhileDriving")
sample70 <- read.csv("N6.csv", stringsAsFactors=F)
newvariable <- as.vector(sample70$val)

vals <- rollapply(zoo(c(newvariable)), width = 50, by = 1, FUN = median, align = "left")
vals
write.csv(vals, "tone.csv")

setwd("C:\\Users\\Lenovo\\Desktop\\IIIT-Delhi\\semester 7\\IP_LOGS\\WhileNotDriving")
sample70 <- read.csv("N4.csv", stringsAsFactors=F)
newvariable <- as.vector(sample70$val)
vals <- rollapply(zoo(c(newvariable)), width = 50, by = 1, FUN = median, na.rm = TRUE, align = "left")
write.csv(vals, "tzero.csv")


#' Pre solve a system of formulas.
#'
#' \code{presolveSystem} returns a set of remaining formulas and implied constants and functions
#' @param constants (optional) A list of coefficients
#' @return A list of formulas, constants and functions
#' @export
#' @examples
#' presolveSystem(formulas =
#'           list(price = 1 ~ price + coefficient1,
#'                variablecost  = variablecost ~ 0.5 * price + coefficient2), constants=list(coefficient1=3))

presolveSystem <- function(formulas, constants = list()) {
  formulasAfterConstants = evaluateConstants(formulas = formulas, constants =
                                               constants)
  formulasAfterImpliedConstants = do.call(evaluateImpliedConstants, formulasAfterConstants)
  return (do.call(evaluateFunctions, formulasAfterImpliedConstants))
}

#presolveSystem(formulas=list(a=a~b+c, b=a-c~b), constants=list(c=4))

# An internal function to turn a formula into a function
formulaToFunction <- function(formula, constants = list()) {
  toReturn = list()
  allVariables = all.vars(formula[[3]])
  toReturn[[formula[[2]]]] = list(
    `function` = eval(parse(
      text = paste(
        'function(',
        paste(setdiff(allVariables, names(constants)), collapse = ','),
        ')',
        deparse(formula[[3]])
      )
    )),
    representation = paste(formula[[2]], '(',
                           paste(
                             setdiff(allVariables, names(constants)), collapse = ','
                           ),
                           ')')
  )
  return(toReturn)
}

#formulaToFunction(yy~3*log(pp)+oo, constants=list(oo=4))

# An internal function that takes a list of formulas and for marked formulas, it turns them into functions and makes replacements
reduceFormulas = function(formulaList,
                          environmentList,
                          reduceVector) {
  formulaReductionList = Reduce(function(a, e)
    c(a, e), Map(function(y, n) {
      if (length(which(n == reduceVector)) > 0)
        return(formulaToFunction(formula = y, constants = environmentList))
      else{
        return(NULL)
      }
    }, formulaList, names(formulaList)))

  toReturn = list(
    equationList = Filter(function(x)
      ! is.null(x), Map(
        function(y, n) {
          if (length(which(n == reduceVector)) > 0)
            return(NULL)
          else
            return(y)
        }, formulaList, names(formulaList)
      )),
    environmentList = Reduce(
      function(a, e) {
        if (is.null(e))
          return(a)
        else{
          a[[names(e)[1]]] = e[[1]]
          return(a)
        }
      },
      Map(function(y, n) {
        if (length(which(n == reduceVector)) > 0)
          return(formulaToFunction(y)$`function`)
        else{
          return(NULL)
        }
      }, formulaList, names(formulaList)),
      environmentList
    ),
    formulaReductionList = formulaReductionList
  )

  toReturn$equationListTransformed = lapply(toReturn$equationList, function(x) {
    do.call(substitute, list(
      expr = x,
      env = lapply(formulaReductionList, function(y) {
        return(do.call(quote, list(as.formula(
          paste('.', y$representation, sep = '~')
        )[[3]])))
      })
    ))
  })

  return(toReturn)
}

# An internal function that removes formulas that define constants

evaluateConstants = function(formulas,
                             constants = list(),
                             functions = list()) {
  evaluatedOne = F
  for (f in names(formulas)) {
    if (length(setdiff(all.vars(formulas[[f]][[3]]), names(constants))) == 0) {
      # no variable on the right
      constants[[formulas[[f]][[2]]]] = eval(formulas[[f]][[3]], envir =
                                               constants)
      formulas[[f]] = NULL
      evaluatedOne = T
    }
  }
  if (evaluatedOne == T) {
    return(Recall(formulas, constants, functions))
  } else{
    return(list(
      formulas = formulas,
      constants = constants,
      functions = functions
    ))
  }
}

#evaluateConstants(formulas=list(a=w~3, b=u~2+p))

# An internal function that removes formulas that imply  constants (e.g., 6 ~ p - 5 implies that p = 11)

evaluateImpliedConstants = function(formulas,
                                    constants = list(),
                                    functions = list()) {
  evaluatedOne = F
  for (f in names(formulas)) {
    if (length(setdiff(all.vars(formulas[[f]]), names(constants))) == 1) {
      # there is exactly one unknown in formula f
      unknown = setdiff(all.vars(formulas[[f]]), names(constants))
      trySolve = solveSingleFormula(formula = formulas[[f]],
                                    unknown = unknown,
                                    constants = constants)
      if (trySolve$success == T) {
        constants[[unknown]] = trySolve$value
        formulas[[f]] = NULL
        evaluatedOne = T
      }
    }
  }
  if (evaluatedOne == T) {
    return(Recall(formulas, constants, functions))
  } else{
    return(list(
      formulas = formulas,
      constants = constants,
      functions = functions
    ))
  }
}

#evaluateImpliedConstants(formulas=list(a=1+w~3, b=u~2+p))

solveSingleFormula = function(formula, unknown, constants) {
  value1 = 1
  constants[[unknown]] = value1
  error1 = eval(formula[[2]], envir = constants) - eval(formula[[3]], envir = constants)

  value2 = 2
  constants[[unknown]] = value2
  error2 = eval(formula[[2]], envir = constants) - eval(formula[[3]], envir = constants)

  de = (error2 - error1) / (value2 - value1)

  value3 = value2 - error2 / de
  constants[[unknown]] = value3
  error3 = eval(formula[[2]], envir = constants) - eval(formula[[3]], envir = constants)
  if (abs(error3) < 1e-6) {
    return(list(success = T, value = value3))
  } else{
    return(list(success = F))
  }
}

#solveSingleFormula(formula=4~+u+3*y, 'y', list(u=1))

# An internal function that removes formulas that can be turned into functions

evaluateFunctions = function(formulas,
                             constants = list(),
                             functions = list()) {
  evaluatedOne = F
  for (f in names(formulas)) {
    cf = formulas[[f]]
    if (length(cf[[2]]) == 1 &&
        length(all.vars(cf[[2]])) == 1 &&
        is.null(constants[[all.vars(cf[[2]])[[1]]]]) &&
        length(intersect(all.vars(cf[[2]]), all.vars(cf[[3]]))) == 0) {
      reducedFormulas = reduceFormulas(
        formulaList = formulas,
        environmentList = constants,
        reduceVector = c(f)
      )
      evaluatedOne = T
      break
    }
  }
  if (evaluatedOne == T) {
    return(
      Recall(
        formulas = reducedFormulas$equationListTransformed,
        constants = constants,
        functions = c(
          functions,
          Map(
            function(ff)
              ff$`function`,
            reducedFormulas$formulaReductionList
          )
        )
      )
    )
  } else {
    return(list(
      formulas = formulas,
      constants = constants,
      functions = functions
    ))
  }
}


cleanup()
nox<-1; noy<-1;  dev="screen"
cleanup()

a<-Read.SSB_percieved(dir=file.path(data.path,scenario))
i<-0

a<-subset(a,Year==2013)

X11()
 par(mfcol=c(2,1))

by(a,list(a$Year,a$Species.n),function(x) {
      if ((i %% (nox*noy))==0 & nsp>1) {
         newplot(dev,nox,noy,Portrait=TRUE);
         par(mar=c(3,5,3,2))
       }
       i<<-i+1
       mean_SSB<-mean(x$SSB_percieved)
       CV_SSB<-sd(x$SSB_percieved)/mean_SSB
       if (nsp==1) main<-paste("mean:",round(mean_SSB), "t CV:",formatC(CV_SSB,digits=2,format='f'))
       b<-hist(x$SSB_percieved,freq=T,main=main,
             xlab='Percieved SSB')

})

a$logSSB_percieved<-log(a$SSB_percieved)
by(a,list(a$Year,a$Species.n),function(x) {
      if ((i %% (nox*noy))==0 & nsp>1) {
         newplot(dev,nox,noy,Portrait=TRUE);
         par(mar=c(3,5,3,2))
       }
       i<<-i+1
       mean_SSB<-mean(x$logSSB_percieved)
       CV_SSB<-sd(x$logSSB_percieved)
       main=paste("Log values, mean:",round(mean_SSB,2), "t sd:",formatC(CV_SSB,digits=2,format='f'))
       b<-hist(x$logSSB_percieved,freq=T,main=main,
             xlab='Percieved SSB')

})