# Read in data from file
dfr <- read.delim("d:/readings.txt", colClasses=c("character", rep(c("numeric", "integer"), 24)))
dates <- strptime(dfr[,1], "%Y-%m-%d")

# Any bad values?
dfr[which(is.na(dfr))]

# Any duplicated dates
dates[duplicated(dates)]

# Number of rows with no bad values
flags <- as.matrix(dfr[,seq(3,49,2)])>0
sum(apply(flags, 1, all))


#' @title{Plot standard maps}
#'
#' @description {plots a standard set of diagnostic maps}
#'
#' @param plot_set integer-vector defining plots to create
#' \describe{
#'   \item{plot_set=1}{Probability of encounter/non-encounter}
#'   \item{plot_set=2}{Log-expected positive catch rate}
#'   \item{plot_set=3}{Log-predicted density (product of encounter probability and positive catch rates)}
#'   \item{plot_set=4}{Log-positive catch rates (rescaled)}
#'   \item{plot_set=5}{Log-predicted density (rescaled)}
#'   \item{plot_set=6}{Spatio-temporal variation in encounter probability}
#'   \item{plot_set=7}{Spatio-temporal variation in log-positive catch rates}
#'   \item{plot_set=8}{Linear predictor for encounter probability}
#'   \item{plot_set=9}{Linear predictor for positive catch rates}
#'   \item{plot_set=10}{Coefficient of variation for predicted density (available only if \code{Data_Fn(...,Options=c('SD_site_logdensity'=1,...))}}
#'   \item{plot_set=11}{Covariates that are included in the model}
#'   \item{plot_set=12}{Total biomass across all categories (only useful in a multivariate model)}
#'   \item{plot_set=13}{Covariate effects on encounter probability}
#'   \item{plot_set=14}{Covariate effects on positive catch rates}
#'   \item{plot_set=15}{Individual covariate effects on encounter probability}
#'   \item{plot_set=16}{Individual covariate effects on positive catch rates}
#' }
#' @param fit tagged list of outputs from TMB model via \code{Obj$report()}
#' @param TmbData optional tagged list of outputs from fit$data_list or VAST::make_data
#' @param spatial_list required for Method == Stream_network, optional for other spatial models, tagged list of outputs from \code{make_spatial_info}
#' @param Sdreport Standard deviation outputs from TMB model via \code{sdreport(Obj)}
#' @param Panel Whether to plot years for a given category (\code{Panel="Category"}) or categories for a given year ((\code{Panel="Year"})  in each panel figure
#' @param Ylim ylimits for each panel
#' @param Xlim xlimits for each panel
#' @param Zlim value scale limits
#' @param DirName Directory (absolute path)
#' @param PlotName plot names are automatically generated but option to add a modifier
#' @param category_names character vector specifying names for different categories (only used for R package \code{VAST})
#' @param covar_names character vector specifying covariate names for labeling figures
#' @param legend Boolean whether to plot legend or not
#' @param textmargin option to include y-axis text
#' @param option to add arrows between network nodes
#' @param cex size of points for map
#' @param ... arguments passed to \code{par}
#'
#' @return Mat_xt a matrix (rows: modeled knots; column: modeled year) for plotted output of last element of \code{plot_set}
#'

#' @export
plot_maps <-
function(plot_set=3, fit, Sdreport=NULL, Xlim=NULL, Ylim=NULL, Zlim = NULL,
         TmbData=NULL, spatial_list=NULL, Panel="Category",
         DirName=NULL, PlotName=NULL,
         category_names=NULL, covar_names=NULL,
         legend=TRUE, textmargin=NULL, arrows=FALSE, cex=0.5,...){

  # local functions
  logsum = function(vec){ max(vec) + log(sum(exp(vec-max(vec)))) }

  year_labels = fit$year_labels
  years_to_plot = fit$years_to_plot
  Report <- fit$Report
  # Fill in missing inputs
  if( "D_xt" %in% names(Report)){
    # SpatialDeltaGLMM
    category_names = "singlespecies"
    Ncategories = length(category_names)
    Nyears = dim(Report$D_xt)[2]
  }
  if( "D_xct" %in% names(Report)){
    # VAST Version < 2.0.0
    if( is.null(category_names) ) category_names = 1:dim(Report$D_xct)[2]
    Ncategories = dim(Report$D_xct)[2]
    Nyears = dim(Report$D_xct)[3]
  }
  if( "D_xcy" %in% names(Report)){
    # VAST Version >= 2.0.0
    if( is.null(category_names) ) category_names = 1:dim(Report$D_xcy)[2]
    Ncategories = dim(Report$D_xcy)[2]
    Nyears = dim(Report$D_xcy)[3]
  }
  if( "D_gcy" %in% names(Report)){
    # VAST Version >= 8.0.0
    if( is.null(category_names) ) category_names = 1:dim(Report$D_gcy)[2]
    Ncategories = dim(Report$D_gcy)[2]
    Nyears = dim(Report$D_gcy)[3]
  }
  if("dhat_ktp" %in% names(Report)){
    # MIST Version <= 14
    if( is.null(category_names) ) category_names = 1:dim(Report$dhat_ktp)[3]
    Ncategories = dim(Report$dhat_ktp)[3]
    Nyears = dim(Report$dhat_ktp)[2]
  }
  if("dpred_ktp" %in% names(Report)){
    # MIST Version >= 15
    if( is.null(category_names) ) category_names = 1:dim(Report$dpred_ktp)[3]
    Ncategories = dim(Report$dpred_ktp)[3]
    Nyears = dim(Report$dpred_ktp)[2]
  }

  # Errors
  if( Nyears != length(year_labels) ){
    stop("Problem with `year_labels`")
  }
  if( Ncategories != length(category_names) ){
    stop("Problem with `category_names`")
  }

  # Extract elements
  plot_codes <- c("Pres", "Pos", "Dens", "Pos_Rescaled", "Dens_Rescaled", "Eps_Pres", "Eps_Pos", "LinPred_Pres", "LinPred_Pos", "Dens_CV", "Covariates", "Total_dens", "Cov_effects_Pres", "Cov_effects_Pos", "Indiv_cov_effects_Pres", "Indiv_cov_effects_Pos")
  plot_names <- c("presence_absence", "log-positive catch rates", "log-density", "positive catch rates", "density", "epsilon for presence_absence", "epsilon for positive catch rates", "encounter probability linear predictor", "positive catch rates linear predictor", "density CV", "covariates", "total density", "encounter probability covariate effects", "catch rates covariate effects", "encounter probability individual covariate effects", "catch rates individual covariate effects")
  if( is.null(textmargin)){
    textmargin <- c("Probability of encounter", "Density, ln(kg. per square km.)", "Density, ln(kg. per square km.)", "", "", "", "", "", "", "CV of density (dimensionless)", "Covariate value", "Density, ln(kg. per square km.)", "", "", "", "")
  }
  # Select locations to plot
  # if( Nknots<Inf ){
  #   NN_plot = stats::kmeans(x=PlotDF[,c("Lon","Lat")], centers=Nknots, iter.max=50, nstart=2, trace=0)
  #   Match = match( 1:Nknots, NN_plot$cluster)
  #   PlotDF = PlotDF[Match,]
  #   message( "Restricted plotting locations to ", Nknots, " locations" )
  # }

  # Loop through plots
  for(plot_num in plot_set){

    inp_Zlim <- Zlim
    # Extract matrix to plot
    if(plot_num==1){
      # Presence/absence ("Pres")
      if("D_xt"%in%names(Report)) Array_xct = Report$R1_xt
      if("D_xct"%in%names(Report)) Array_xct = Report$R1_xct
      if("D_xcy"%in%names(Report)) Array_xct = Report$R1_xcy
      if("D_gcy"%in%names(Report)) Array_xct = Report$R1_gcy
      # if("D_gcy"%in%names(Report)) stop("`plot_maps` not implemented for requested plot_num")
      if(any(c("dhat_ktp","dpred_ktp")%in%names(Report))) stop("Not implemented for SpatialVAM")
      message( "plot_num=1 doesn't work well when using ObsModel[2]==1" )
      # if(is.null(Zlim)) inp_Zlim <- c(0,1)
    }
    if(plot_num==2){
      # Positive values ("Pos")
      if("D_xt"%in%names(Report)) Array_xct = log(Report$R2_xt)
      if("D_xct"%in%names(Report)) Array_xct = log(Report$R2_xct)
      if("D_xcy"%in%names(Report)) Array_xct = log(Report$R2_xcy)
      if("D_gcy"%in%names(Report)) Array_xct = log(Report$R2_gcy)
      # if("D_gcy"%in%names(Report)) stop("`plot_maps` not implemented for requested plot_num")
      if(any(c("dhat_ktp","dpred_ktp")%in%names(Report)))  stop("Not implemented for SpatialVAM")
    }
    if(plot_num==3){
      # Density ("Dens")
      if("D_xt"%in%names(Report)) Array_xct = log(Report$D_xt)
      if("D_xct"%in%names(Report)) Array_xct = log(Report$D_xct)
      if("D_xcy"%in%names(Report)) Array_xct = log(Report$D_xcy)
      if("D_gcy"%in%names(Report)) Array_xct = log(Report$D_gcy)
      if("dhat_ktp" %in% names(Report)) Array_xct = aperm(Report$dhat_ktp[,,cI],c(1,3,2))
      if("dpred_ktp" %in% names(Report)) Array_xct = aperm(Report$dpred_ktp[,,cI],c(1,3,2))
    }
    if(plot_num==4){
      # Positive values rescaled ("Pos_Rescaled")
      if("D_xt"%in%names(Report)) Array_xct = log(Report$R2_xt+quantile(Report$R2_xt,0.25))
      if("D_xct"%in%names(Report)) Array_xct = log(Report$R2_xct+quantile(Report$R2_xct,0.25))
      if("D_xcy"%in%names(Report)) Array_xct = log(Report$R2_xcy+quantile(Report$R2_xcy,0.25))
      if("D_gcy"%in%names(Report)) Array_xct = log(Report$R2_gcy+quantile(Report$R2_gcy,0.25))
      # if("D_gcy"%in%names(Report)) stop("`plot_maps` not implemented for requested plot_num")
      if(any(c("dhat_ktp","dpred_ktp")%in%names(Report)))  stop("Not implemented for SpatialVAM")
    }
    if(plot_num==5){
      # Density rescaled ("Dens_Rescaled")
      # if("D_xt"%in%names(Report)) Array_xct = log(Report$D_xt+quantile(Report$D_xt,0.25))
      # if("D_xct"%in%names(Report)) Array_xct = log(Report$D_xct+quantile(Report$D_xct,0.25))
      # if("D_xcy"%in%names(Report)) Array_xct = log(Report$D_xcy+quantile(Report$D_xcy,0.25))
      # if("D_gcy"%in%names(Report)) Array_xct = log(Report$D_gcy+quantile(Report$D_gcy,0.25))
      if("D_xt"%in%names(Report)) Array_xct = Report$D_xt
      if("D_xct"%in%names(Report)) Array_xct = Report$D_xct
      if("D_xcy"%in%names(Report)) Array_xct = Report$D_xcy
      if("D_gcy"%in%names(Report)) Array_xct = Report$D_gcy

      # if("D_gcy"%in%names(Report)) stop("`plot_maps` not implemented for requested plot_num")
      if(any(c("dhat_ktp","dpred_ktp")%in%names(Report)))  stop("Not implemented for SpatialVAM")
    }
    if(plot_num==6){
      # Epsilon for presence/absence ("Eps_Pres")
      if("D_xt"%in%names(Report)) Array_xct = Report$Epsilon1_st
      if("D_xct"%in%names(Report)) Array_xct = Report$Epsilon1_sct
      if("D_xcy"%in%names(Report)) Array_xct = Report$Epsilon1_sct
      if("D_gcy"%in%names(Report)) Array_xct = Report$Epsilon1_gct
      if(any(c("dhat_ktp","dpred_ktp")%in%names(Report)))  stop("Not implemented for SpatialVAM")
    }
    if(plot_num==7){
      # Epsilon for positive values ("Eps_Pos")
      if("D_xt"%in%names(Report)) Array_xct = Report$Epsilon2_st
      if("D_xct"%in%names(Report)) Array_xct = Report$Epsilon2_sct
      if("D_xcy"%in%names(Report)) Array_xct = Report$Epsilon2_sct
      if("D_gcy"%in%names(Report)) Array_xct = Report$Epsilon2_gct
      if(any(c("dhat_ktp","dpred_ktp")%in%names(Report)))  stop("Not implemented for SpatialVAM")
    }
    if(plot_num==8){
      # Linear predictor for probability of encounter
      if("D_xt"%in%names(Report)) Array_xct = Report$P1_xt
      if("D_xct"%in%names(Report)) Array_xct = Report$P1_xct
      if("D_xcy"%in%names(Report)) Array_xct = Report$P1_xcy
      if("D_gcy"%in%names(Report)) stop("`plot_maps` not implemented for requested plot_num")
      if(any(c("dhat_ktp","dpred_ktp")%in%names(Report)))  stop("Not implemented for SpatialVAM")
    }
    if(plot_num==9){
      # Linear predictor for positive catch rates
      if("D_xt"%in%names(Report)) Array_xct = Report$P2_xt
      if("D_xct"%in%names(Report)) Array_xct = Report$P2_xct
      if("D_xcy"%in%names(Report)) Array_xct = Report$P2_xcy
      if("D_gcy"%in%names(Report)) stop("`plot_maps` not implemented for requested plot_num")
      if(any(c("dhat_ktp","dpred_ktp")%in%names(Report)))  stop("Not implemented for SpatialVAM")
    }
    if(plot_num==10){
      # Density ("Dens") CV             # Index_xtl
      if( is.null(Sdreport) ) stop("Must supply 'Sdreport' if 'plot_num=10'")
      if("D_xt"%in%names(Report)){
        if( !("log(Index_xtl)" %in% rownames(TMB::summary.sdreport(Sdreport))) ) stop("Please re-run with Options('SD_site_logdensity'=1,...) to use 'plot_num=10' in 'SpatialDeltaGLMM'")
        Array_xct = array( TMB::summary.sdreport(Sdreport)[which(rownames(TMB::summary.sdreport(Sdreport))=="log(Index_xtl)"),], dim=c(dim(Report$D_xt),ncol(Report$Index_tl),2), dimnames=list(NULL,NULL,NULL,c('Estimate','Std. Error')) )[,,1,'Std. Error']
      }
      if("D_xct"%in%names(Report)){
        if( !("log(Index_xctl)" %in% rownames(TMB::summary.sdreport(Sdreport))) ) stop("Please re-run with Options('SD_site_logdensity'=1,...) to use 'plot_num=10' in 'VAST'")
        Array_xct = array( TMB::summary.sdreport(Sdreport)[which(rownames(TMB::summary.sdreport(Sdreport))=="log(Index_xctl)"),], dim=c(dim(Report$D_xct),dim(Report$Index_ctl)[3],2), dimnames=list(NULL,NULL,NULL,NULL,c('Estimate','Std. Error')) )[,,,1,'Std. Error']
      }
      if("D_xcy"%in%names(Report)){
        if( !("log(Index_xcyl)" %in% rownames(TMB::summary.sdreport(Sdreport))) ) stop("Please re-run with Options('SD_site_logdensity'=1,...) to use 'plot_num=10' in 'VAST'")
        Array_xct = array( TMB::summary.sdreport(Sdreport)[which(rownames(TMB::summary.sdreport(Sdreport))=="log(Index_xcyl)"),], dim=c(dim(Report$D_xcy),dim(Report$Index_cyl)[3],2), dimnames=list(NULL,NULL,NULL,NULL,c('Estimate','Std. Error')) )[,,,1,'Std. Error']
      }
      if("D_gcy"%in%names(Report)){
        if( !("log(Index_gcyl)" %in% rownames(TMB::summary.sdreport(Sdreport))) ) stop("Please re-run with Options('SD_site_logdensity'=1,...) to use 'plot_num=10' in 'VAST'")
        Array_xct = array( TMB::summary.sdreport(Sdreport)[which(rownames(TMB::summary.sdreport(Sdreport))=="log(Index_gcyl)"),], dim=c(dim(Report$D_gcy),dim(Report$Index_cyl)[3],2), dimnames=list(NULL,NULL,NULL,NULL,c('Estimate','Std. Error')) )[,,,1,'Std. Error']
      }
      if(any(c("dhat_ktp","dpred_ktp")%in%names(Report))) stop("'plot_num=10' not implemented for 'SpatialVAM'")
      # Convert to CV
      Array_xct = sqrt( exp(Array_xct^2) - 1 )
      if("D_gcy"%in%names(Report)) stop("`plot_maps` not implemented for requested plot_num")
    }
    if(plot_num==11){
      if(is.null(TmbData)) stop( "Must provide `TmbData` to plot covariates" )
      if(!("X_gtp" %in% names(TmbData))) stop( "Can only plot covariates for VAST version >= 2.0.0" )
      Array_xct = aperm( TmbData$X_gtp, perm=c(1,3,2) )
      category_names = 1:dim(Array_xct)[2]
    }
    if(plot_num==12){
      # Total density ("Dens")
      if("D_xt"%in%names(Report)) Array_xct = log(Report$D_xt)
      if("D_xct"%in%names(Report)) Array_xct = log(apply(Report$D_xct,FUN=sum,MARGIN=c(1,3)))
      if("D_xcy"%in%names(Report)) Array_xct = log(apply(Report$D_xcy,FUN=sum,MARGIN=c(1,3)))
      if("D_gcy"%in%names(Report)) Array_xct = log(apply(Report$D_gcy,FUN=sum,MARGIN=c(1,3)))
      if("dhat_ktp" %in% names(Report)) Array_xct = apply(aperm(Report$dhat_ktp,c(1,3,2)),FUN=logsum,MARGIN=c(1,3))
      if("dpred_ktp" %in% names(Report)) Array_xct = apply(aperm(Report$dpred_ktp,c(1,3,2)),FUN=logsum,MARGIN=c(1,3))
    }
    if(plot_num==13){
      # Covariate effects for probability of encounter
      if("D_xt"%in%names(Report)) stop()
      if("D_xct"%in%names(Report)) stop()
      if("D_xcy"%in%names(Report)) Array_xct = Report$eta1_xct
      if("D_gcy"%in%names(Report)) Array_xct = Report$eta1_gct
      if("dhat_ktp" %in% names(Report)) stop()
      if("dpred_ktp" %in% names(Report)) stop()
    }
    if(plot_num==14){
      # Covariate effects for positive catch rates
      if("D_xt"%in%names(Report)) stop()
      if("D_xct"%in%names(Report)) stop()
      if("D_xcy"%in%names(Report)) Array_xct = Report$eta2_xct
      if("D_gcy"%in%names(Report)) Array_xct = Report$eta2_gct
      if("dhat_ktp" %in% names(Report)) stop()
      if("dpred_ktp" %in% names(Report)) stop()
    }
    if(plot_num==15){
      if(is.null(TmbData)) stop("Must provide `TmbData` to plot covariates.")
      if(!("X_gtp" %in% names(TmbData))) stop( "Can only plot covariates for VAST version >= 2.0.0")

        X <- TmbData$X_gtp
        # gamma1_ctp <- summary(Sdreport)[which(grepl("gamma1", rownames(summary(Sdreport)))),"Estimate"]
        gamma1_ctp <- Sdreport$par.fixed[grepl("gamma1_ctp", names(Sdreport$par.fixed))]

        n_p <- dim(X)[3]
        category_names <- covar_names
        Array_xct <- array(NA, dim=c(dim(X)[1], n_p, dim(X)[2]))
        for(i in 1:n_p){
          eta <- gamma1_ctp[i] * X[,,i]
          Array_xct[,i,] <- eta
        }
    }
    if(plot_num==16){
      if(is.null(TmbData)) stop("Must provide `TmbData` to plot covariates.")
      if(!("X_gtp" %in% names(TmbData))) stop( "Can only plot covariates for VAST version >= 2.0.0")

        X <- TmbData$X_gtp
        # gamma1_ctp <- summary(Sdreport)[which(grepl("gamma1", rownames(summary(Sdreport)))),"Estimate"]
        gamma2_ctp <- Sdreport$par.fixed[grepl('gamma2_ctp', names(Sdreport$par.fixed))]

        n_p <- dim(X)[3]
        category_names <- covar_names
        Array_xct <- array(NA, dim=c(dim(X)[1], n_p, dim(X)[2]))
        for(i in 1:n_p){
          eta <- gamma2_ctp[i] * X[,,i]
          Array_xct[,i,] <- eta
        }
    }

      # require(ggplot2)
      if(all(is.null(spatial_list))) stop("add spatial_list (output from FishStatsUtils::make_spatial_info) to use ggplot2 plots.")

    # Plot for each category
    if( tolower(Panel)=="category" ){
      if(length(dim(Array_xct))==2) Nplot = 1
      if(length(dim(Array_xct))==3) Nplot = dim(Array_xct)[2]
      for( cI in 1:Nplot){
        if(length(dim(Array_xct))==2) Return = Mat_xt = Array_xct
        if(length(dim(Array_xct))==3) Return = Mat_xt = Array_xct[,cI,]

          ## matrix is number of nodes by number of years
          if(is.null(dim(Mat_xt)))  n_t = 1 else n_t <- dim(Mat_xt)[2]
          if(n_t != length(year_labels)) stop("number of years in density array does not match Data_Geostat years")
          if(n_t > 1) {
            xct <- lapply(1:n_t, function(x){
              out <- data.frame('value'=Mat_xt[,x], 'year'=year_labels[x], spatial_list$loc_g, 'category'=category_names[cI])
              return(out)
            })
            xct <- do.call(rbind, xct)
          } else xct <- data.frame('value'=Mat_xt, 'year'=year_labels, spatial_list$loc_g, "category"=category_names[1])

          if(all(is.null(Xlim))) Xlim = c(min(xct$E_km),max(xct$E_km))
          if(all(is.null(Ylim))) Ylim = c(min(xct$N_km),max(xct$N_km))
          p <- ggplot(xct)
          if(arrows == TRUE){
            Network_sz_EN <- data.frame('parent_s'=fit$data_list$parent_s, 'child_s'=fit$data_list$child_s, fit$spatial_list$loc_g)
            l2 <- lapply(1:nrow(Network_sz_EN), function(x){
              parent <- Network_sz_EN$parent_s[x]
              find <- Network_sz_EN %>% filter(child_s == parent)
              if(nrow(find)>0) out <- cbind.data.frame(Network_sz_EN[x,], 'E2'=find$E_km, 'N2'=find$N_km)
              if(nrow(find)==0) out <- cbind.data.frame(Network_sz_EN[x,], 'E2'=NA, 'N2'=NA)
              # if(nrow(find)>0) out <- cbind.data.frame(Network_sz_EN[x,], 'long2'=find$long, 'lat2'=find$lat)
              # if(nrow(find)==0) out <- cbind.data.frame(Network_sz_EN[x,], 'long2'=NA, 'lat2'=NA)
              return(out)
            })
            l2 <- do.call(rbind, l2)
            p <- p + geom_segment(data=l2, aes(x = E_km,y = N_km, xend = E2, yend = N2), arrow=arrow(length=unit(0.2,"cm")), col="gray")
          }
          if(is.null(Zlim)) inp_Zlim = quantile(xct$value, prob = c(0,1), na.rm=TRUE)
          p <- p +
              geom_point(aes(x = E_km, y = N_km, color = value), cex = cex) +
              scale_color_distiller(palette = "Spectral", limits = inp_Zlim) +
              coord_cartesian(xlim = Xlim, ylim = Ylim) +
              scale_x_continuous(breaks=quantile(xct$E_km, prob=c(0.1,0.5,0.9)), labels=round(quantile(xct$E_km, prob=c(0.1,0.5,0.9)),0)) +
              # guides(color=guide_legend(title=plot_codes[plot_num])) +
              facet_wrap(~year) +
              mytheme() +
              xlab("Eastings") + ylab("Northings")
          if(Nplot!=1) p <- p + ggtitle(paste(category_names[cI], plot_names[plot_num], PlotName))
          if(Nplot==1) p <- p + ggtitle(paste(plot_names[plot_num], PlotName))

          if(!is.null(DirName)){
            if(Nplot!=1) ggsave(file.path(DirName, paste0(plot_names[plot_num], PlotName, "_", cI, "_byCat.png")), p, width=8,height=8)
            if(Nplot==1) ggsave(file.path(DirName, paste0(plot_names[plot_num], PlotName, "_byCat.png")), p, width=8,height=8)
          }
          if(is.null(DirName)){
            dev.new()
            print(p)
          }
      }
    }
    # Plot for each year
    if( tolower(Panel)=="year" ){
      Nplot = length(years_to_plot)
      for( tI in 1:Nplot){
        if(length(dim(Array_xct))==2) Mat_xc = Array_xct[,years_to_plot[tI],drop=TRUE]
        if(length(dim(Array_xct))==3) Mat_xc = Array_xct[,,years_to_plot[tI],drop=TRUE]
        if(is.null(dim(Mat_xc)) & is.vector(Mat_xc)){
          Ncategories = 1
        } else { Ncategories = dim(Mat_xc)[2] }
        Return = Mat_xc = array( as.vector(Mat_xc), dim=c(dim(Array_xct)[1],Ncategories)) # Reformat to make sure it has same format for everything

         ## matrix is number of nodes by number of years
          n_c <- dim(Mat_xc)[2]
          if(n_c > 1) {
            xct <- lapply(1:n_c, function(x){
              out <- data.frame('value'=Mat_xc[,x], 'year'=year_labels[years_to_plot[tI]], spatial_list$loc_g, 'category'=category_names[x])
              return(out)
            })
            xct <- do.call(rbind, xct)
          } else xct <- data.frame('value'=Mat_xc, 'year'=year_labels[years_to_plot[tI]], spatial_list$loc_g, "category"='total')
          if(all(is.null(Xlim))) Xlim = c(min(xct$E_km),max(xct$E_km))
          if(all(is.null(Ylim))) Ylim = c(min(xct$N_km),max(xct$N_km))
          p <- ggplot(xct)
          if(arrows == TRUE){
            Network_sz_EN <- data.frame('parent_s'=fit$data_list$parent_s, 'child_s'=fit$data_list$child_s, fit$spatial_list$loc_g)
            l2 <- lapply(1:nrow(Network_sz_EN), function(x){
              parent <- Network_sz_EN$parent_s[x]
              find <- Network_sz_EN %>% filter(child_s == parent)
              if(nrow(find)>0) out <- cbind.data.frame(Network_sz_EN[x,], 'E2'=find$E_km, 'N2'=find$N_km)
              if(nrow(find)==0) out <- cbind.data.frame(Network_sz_EN[x,], 'E2'=NA, 'N2'=NA)
              # if(nrow(find)>0) out <- cbind.data.frame(Network_sz_EN[x,], 'long2'=find$long, 'lat2'=find$lat)
              # if(nrow(find)==0) out <- cbind.data.frame(Network_sz_EN[x,], 'long2'=NA, 'lat2'=NA)
              return(out)
            })
            l2 <- do.call(rbind, l2)
            p <- p + geom_segment(data=l2, aes(x = E_km,y = N_km, xend = E2, yend = N2), arrow=arrow(length=unit(0.2,"cm")), col="gray")
          }
          if(is.null(Zlim)) inp_Zlim = quantile(xct$value, prob = c(0,1), na.rm=TRUE)
          p <- p +
              geom_point(aes(x = E_km, y = N_km, color = value), cex=cex) +
              scale_color_distiller(palette = "Spectral", limits = inp_Zlim) +
              coord_cartesian(xlim = Xlim, ylim = Ylim) +
              scale_x_continuous(breaks=quantile(xct$E_km, prob=c(0.1,0.5,0.9)), labels=round(quantile(xct$E_km, prob=c(0.1,0.5,0.9)),0)) +
              # guides(color=guide_legend(title=plot_codes[plot_num])) +
              facet_wrap(~category) +
              mytheme() +
              xlab("Eastings") + ylab("Northings")

          if(n_c == 1) width = 6; height = 5
          if(n_c > 1) width = 10; height = 5
          if(Nplot!=1) p <- p + ggtitle(paste(year_labels[years_to_plot[tI]], plot_names[plot_num], PlotName))
          if(Nplot==1) p <- p + ggtitle(paste(plot_names[plot_num], PlotName))

          if(!is.null(DirName)){
            if(Nplot!=1) ggsave(file.path(DirName, paste0(plot_names[plot_num], PlotName, "_", tI, "_byYear.png")), p, width=width, height=height)
            if(Nplot==1) ggsave(file.path(DirName, paste0(plot_names[plot_num], PlotName, "_byYear.png")), p, width = width, height = height)
          }
          if(is.null(DirName)){
            dev.new()
            print(p)
          }
      }
    }
  }

  return( invisible(Return) )
}


library(showtext)
showtext.auto(enable = TRUE)
font.add('Consolas', 'consola.ttf')
pdf('test.pdf')
t<-seq(-3.14,3.14,0.5)
plot(t,sin(t), xlab = '', ylab = '',type='b',col='blue',
     main = '', family = 'Consolas')
dev.off()
system('cmd /c start test.pdf')


#plotting variable importance: functional groups.
#Clear environment, source paths, packages and functions.
rm(list=ls())
source('paths.r')

#set output path.----
output.path <- 'test.png'

#load data.----
d <- readRDS(NEON_var_importance_data_ddirch_16S.path)

#set output spec.----
png(filename=output.path,width=8,height=8,units='in',res=300)

#Global plot settings.----
par(mfrow = c(2,2))
outer.lab.cex <- 1.5

#loop over different bacterial groups.----
for (f in 1:length(d)){

for(i in 1:ncol(d[[f]]$mean)){
  #plot importance in decreasing order.
  if (colnames(d[[f]]$mean)[i]=="other") next
  mu   <- d[[f]]$mean[,i][order(d[[f]]$mean[,i], decreasing = T)]
  hi95 <- d[[f]]$ci_0.975[,i][order(match(names(d[[f]]$ci_0.975[,i]), names(mu)))]
  lo95 <- d[[f]]$ci_0.025[,i][order(match(names(d[[f]]$ci_0.025[,i]), names(mu)))]
  limy <- c(0,max(hi95) * 1.01)
  lab <- names(mu)
  fungi.name <- colnames(d[[f]]$mean)[i]
  J<-barplot(height = mu,
             beside = true, las = 2,
             ylim = limy,
             cex.names = 0.75, xaxt = "n",
             main = paste0(fungi.name),
             border = "black", axes = TRUE)
  #add error bars.
  segments(J, lo95, J, hi95, lwd = 1.5)
  #add variable labels.
  ypos <- -limy[2] / 10
  text(x = J, y = ypos, srt = 45,
       adj = 1, labels = lab, xpd = TRUE)
}
}
#Outer labels.----
mtext('Variable Importance',side = 2, line = 2, cex = outer.lab.cex, outer = T)

#end plot.----
dev.off()


library("xml2")
library("dplyr")
library("stringr")
library("rlist")
library("xts")
library("quantmod")
library("PortfolioAnalytics")
library("DEoptim")
library("ROI")
require("ROI.plugin.glpk")
require("ROI.plugin.quadprog")

###first filter
first_filter<-function(data,ins){

    risk_all<-c() #annual volatility
    outline_all<-data.frame()
    fund_num<-ncol(data)/2

    outfund_all<-data.frame()
    sel_all<-c()
    data2<-data.frame()

    ###calculate return and volatility
    ###first, eliminate funds begin after 2014-12-01, and convert data to standard format to prepare for later functions
    for(k1 in 1:fund_num){
        if(is.null(data[2,(2*k1-1)])){break}
        if(as.Date(data[1,(2*k1-1)])>="2014-12-01"){next}
        tmp<-as.character(data[,(2*k1-1)])
        temp<-as.Date(tmp,format="%Y/%m/%d")
        data1<-data.frame(temp,data[,2*k1])
        data1<-na.omit(data1,data1[,1:2])
        data1<-xts(data1[,2],data1[,1])
        colnames(data1)<-colnames(data[(2*k1-1)])
        return<-periodReturn(data1,period="yearly",type="log")
        data2<-merge.xts(data1,data2)
        risk<-var(return)#risk
        risk_all<-c(risk_all,risk)
    }
    fund_num<-max(index(risk_all))

    ###sort by volatility, and choose by input
    sorted_risk_all<-sort(risk_all,decreasing=FALSE) #in decreasing order  3锟斤拷2*79+1:3*79
    selected<-head(sorted_risk_all,ins*fund_num/10)[floor((ins-1)*fund_num/10+1):ceiling(ins*fund_num/10)]#because fund_num/10 might not be integer
    selected_index<-match(selected,risk_all)
    for(k in selected_index){
        outfund<-data2[,k]#
        outfund<-na.omit(outfund,outfund[,1])
        outfund_all<-merge.xts(outfund,outfund_all)}
        outfund_all<-as.data.frame(outfund_all)
        #write.csv(outfund_all,"outfund.csv",na="")
    return (outfund_all)
}

###second filter
second_filter<-function(data,single_fund_num){

    #print(rownames(data))
    date_tmp = as.Date(rownames(data),format="%Y-%m-%d")
    data = cbind(date_tmp,data)

    data2<-data.frame()
    return_all<-c()
    fund_num<-ncol(data)
    final_fund_all<-data.frame()

for(k1 in 1:fund_num){
    if(is.null(data[2,(k1+1)])){break}
    data1<-data.frame(data[,1],data[,(k1+1)])
    data1<-na.omit(data1,data1[,1:2])
    data1<-xts(data1[,2],as.Date(data1[,1]))
    return<-periodReturn(data1,period="yearly",type="log")
    return_avg<-mean(return)
    return_all<-c(return_avg,return_all)
    data2<-merge.xts(data1,data2)
}
    #Debugging
    if(FALSE){
        print("rows for data")
        print(nrow(data))
        print(ncol(data))
        print(head(data[,1]))
        print(typeof(data[,1]))
        print(rownames(data))
        print(typeof(rownames(data)))
        print("rows for data")
        print(nrow(data))
        print(ncol(data))
        print("rows for data 2")
        print(nrow(data2))
        print(ncol(data2))
        print("data 2")
        print(head(data2,5))
    }

    #print(return_all)
    sorted_return_all<-sort(return_all,decreasing=TRUE)
    #print(sorted_return_all)
    selected_index<-match(head(sorted_return_all,single_fund_num),return_all)
    #print(selected_index)

    for(k in selected_index){
    final_fund<-data2[,(fund_num - k)]
    final_fund<-na.omit(final_fund,final_fund[,1])
    colnames(final_fund)<-colnames(data)[(k+1)]
    final_fund_all<-merge.xts(final_fund,final_fund_all)
    }
    final_fund_all<-as.data.frame(final_fund_all)

    #Debugging
    #dataall<-rbind(final_fund_all,return_all)
    #for(k in selected_index){
    #final_fund<-data.frame(data[,1],data[,(k+1)])
    #final_fund<-na.omit(final_fund,final_fund[,1:2])
    #colnames(final_fund)<-c("Date",colnames(data[k+1]))
    #final_fund_all<-bind_cols(final_fund,final_fund_all)
    #}

    #write.csv(final_fund_all,"finalfund.csv",na="")
    return (final_fund_all)
}

weights<-function(data) {
    ### Read data from last milestone
    #setwd("C:/Users/EDZ/Desktop/鐞嗕韩瀹?/Portfolio_Proj") #can be specified
    #data = read.csv("finalfund.csv",header = TRUE, fileEncoding = "UTF-8", sep=",", na.strings = "")
    #data = final_fund_all

    #print(rownames(data))
    date_tmp = as.Date(rownames(data),format="%Y-%m-%d")
    data = cbind(date_tmp,data)

    rows = nrow(data)
    fund_num = ncol(data) - 1

    #Debugging
    if(FALSE){
        print("rows:")
        print(rows)
        print("cols:")
        print(ncol(data))
    }
    #tmp = as.character(data[,1])
    #data[,1] = as.Date(tmp, format="%Y/%m/%d")

    ###Step 1: Complete all funds
    for (j in 1:fund_num){
        for (i in 1:rows){
            if(is.na(data[i,j+1])){
                if(i != rows){
                    #last_data = data[i-1,j+1]
                    i_tmp = i + 1;
                    while(is.na(data[i_tmp,j+1])) i_tmp = i_tmp + 1
                    data[i,j+1] = (data[i-1,j+1] + data[i_tmp,j+1]) / 2
                }
                else{
                    data[i,j+1] = data[i-1,j+1]
                }
            }
        }
    }

    ###last version
    if(FALSE){
        if(FALSE){
            ###Step 1: find the fund with most dates
            fund_most_date = 1
            MAX_date = 1
            for (j in 1:fund_num){
                i = 1
                while(!is.na(data[i,j+1]))
                    i = i + 1
                if(i > MAX_date) {
                    MAX_date = i
                    fund_most_date = j
                }
            }
        }
        if(fund_most_date != fund_num){
        for (j in (fund_most_date+1):fund_num){
            for (i in i:rows){
                if(is.na(data[i,j+1])){
                    if(i != rows){
                        #new input format do not require data moving
                        if(FALSE)
                        {
                            #move the dates
                            data[(i+1):rows,2*j] = data[i:(rows-1),2*j]
                            data[(i+1):rows, 2*j+1] = data[i:(rows-1),2*j+1]
                            data[i,2*j] = data[i,2*fund_most_date]
                            data[i,2*j+1] = (data[i-1,2*j+1] + data[i+1,2*j+1]) /2
                        }
                        data[i,j+1] = (data[i-1,j+1] + data[i+1,j+1]) /2
                    }
                    else{
                        data[i,j+1] = data[i-1,j+1]
                    }
                }
            }
        }
    }

        if(fund_most_date != fund_num){
            for (j in (fund_most_date+1):fund_num){

                for (i in i :rows){
                    if(is.na(data[i,2*j]) || (data[i,2*j] > data[i, 2*fund_most_date])){
                        if(i != rows){
                            #move the dates
                            data[(i+1):rows,2*j] = data[i:(rows-1),2*j]
                            data[(i+1):rows, 2*j+1] = data[i:(rows-1),2*j+1]
                            data[i,2*j] = data[i,2*fund_most_date]
                            data[i,2*j+1] = (data[i-1,2*j+1] + data[i+1,2*j+1]) /2
                        }
                        else{
                            data[i,2*j] = data[i,2*fund_most_date]

                            data[i,2*j+1] = data[i,2*fund_most_date+1]
                        }
                    }
                }
            }
        }
    }

    ### Step 2: Construct the system by Markowitz model
    #Initialization
    rows = nrow(data)
    returns_tmp = c()
    return_tmp = data.frame()

    for (j in 1:fund_num){
        data_tmp <- data.frame(data[,1],data[,j+1])
        data_tmp <- xts(data_tmp[,2],as.Date(data_tmp[,1]))
        return_tmp <- periodReturn(data_tmp,period="daily",type="log")
        returns_tmp <- cbind(returns_tmp,return_tmp)
    }

    returns <- returns_tmp[,1:5]
    rownames(returns) <- data[,1]
    colnames(returns) <- c("fd1", "fd2", "fd3", "fd4","fd5")
    funds <- colnames(returns)
    init <- portfolio.spec(assets = funds)
    init <- add.constraint(portfolio=init, type="leverage",min_sum=0.99, max_sum=1.01)
    init <- add.constraint(portfolio=init, type="box", min=0.10, max=0.40)
    #print.default(init)

    #6.2 Maximize mean return with ROI
    #max_ret <- add.objective(portfolio=init, type="return", name="mean")
    #opt_maxret <- optimize.portfolio(R=returns, portfolio=max_ret, optimize_method="ROI",trace=TRUE)
    #print(opt_maxret)
    #plot(opt_maxret, risk.col="StdDev", return.col="mean", main="Maximum Return Optimization", chart.assets=TRUE, xlim = c(0,1), ylim = c(0,30))

    #6.3 Minimize variance with ROI
    minvar <- add.objective(portfolio=init, type="risk", name="var")
    opt_minvar <- optimize.portfolio(R=returns, portfolio=minvar, optimize_method="ROI", trace=TRUE)
    #print(opt_minvar)
    #plot(opt_minvar, risk.col="StdDev", return.col="mean", main="Minimum Variance Optimization", chart.assets=TRUE, xlim = c(0,1), ylim = c(0,200))

    #6.4 Maximize quadratic utility with ROI
    #qu <- add.objective(portfolio=init, type="return", name="mean")
    #qu <- add.objective(portfolio=qu, type="risk", name="var", risk_aversion=0.25) #can be specified
    #opt_qu <- optimize.portfolio(R=returns, portfolio=qu, optimize_method="ROI", trace=TRUE)
    #print(opt_qu)
    #plot(opt_qu, risk.col="StdDev", return.col="mean", main="Quadratic Utility Optimization", chart.assets=TRUE, xlim = c(0,1), ylim = c(0,200))

    #6.5 Minimize expected tail loss with ROI
    #etl <- add.objective(portfolio=init, type="risk", name="ETL")
    #opt_etl <- optimize.portfolio(R=returns, portfolio=etl, optimize_method="ROI", trace=TRUE)
    #print(opt_etl)
    #plot(opt_etl, risk.col="ES", return.col="mean", main="ETL Optimization", chart.assets=TRUE, xlim = c(0,1), ylim = c(0,200))

    #6.6 Maximize mean return per unit ETL with random portfolios
    #meanETL <- add.objective(portfolio = init, type = "return", name = "mean")
    #meanETL <- add.objective(portfolio = meanETL, type="risk", name="ETL", arguments=list(p=0.95))
    #opt_meanETL <- optimize.portfolio(R=returns, portfolio = meanETL, optimize_method = "random", trace = TRUE, search_size = 2000)
    #print(opt_meanETL)
    #stats_meanETL <-extractStats(opt_meanETL)
    #head(stats_meanETL)
    #plot(opt_meanETL, risk.col="ETL", return.col="mean", main="mean-ETL Optimization", neighbors=25)

    w = extractWeights(opt_minvar)

    return (w)
}

R_final<-function(data,ins){
    filted_1 <- first_filter(data,ins)
    filted_2 <- second_filter(filted_1,5)
    w<-weights(filted_2)
    return (w)
}

data<-read.csv("test.csv",header=TRUE,sep=",")
print(R_final(data,5))


# 4. faza: Analiza podatkov

#Slovenija
library(plyr)
library(dplyr)
library(data.table)

tab <- Tabela1[Tabela1$`Kmetijska gospodarstva` %in% c("Kmetijska gospodarstva", "Kmetijska gospodarstva z ekološkim kmetovanjem", "Kmetijska gospodarstva v postopku preusmeritve v ekološko kmetovanje"), ]
tab$`Kmetijska gospodarstva`[tab$`Kmetijska gospodarstva` == "Kmetijska gospodarstva v postopku preusmeritve v ekološko kmetovanje"] <- "Kmetijska gospodarstva z ekološkim kmetovanjem"
tab[is.na(tab)] <- 0
tab$`Kmetijska gospodarstva`[tab$`Kmetijska gospodarstva` == "Kmetijska gospodarstva z ekološkim kmetovanjem"] <- "Kmetijska gospodarstva z ekoloskim kmetovanjem"

DT <- data.table(tab)
dt <- DT[, sum(stevilo), by = c("Kmetijska gospodarstva", "leto")]
colnames(dt)=c("Kmetijska gospodarstva", "leto", "stevilo")
dt$stevilo[4] <- 1400

for (row in 1:nrow(dt)) {
  leto_x <- dt[row, "leto"]
  tip  <- dt[row, "Kmetijska gospodarstva"]
  stevilo <- dt[row, "stevilo"]
  if(tip == "Kmetijska gospodarstva"){
    stevilo_eko <- (dt[as.numeric(dt$leto) == as.numeric(leto_x) & dt$`Kmetijska gospodarstva` == "Kmetijska gospodarstva z ekoloskim kmetovanjem", "stevilo"])
    dt[row, "stevilo"] <- stevilo - stevilo_eko}}

colnames(dt)=c("Kmetije", "leto", "stevilo")

tabela_kmet_gosp <- dt[Kmetije == "Kmetijska gospodarstva"]
tabela_kmet_gosp$Kmetije <- NULL
tabela_kmet_gosp <- as.data.frame(tabela_kmet_gosp)
tabela_kmet_gosp$leto <- as.numeric(as.character(tabela_kmet_gosp$leto))
tabela_kmet_gosp_lm <- lm(formula = stevilo ~ leto, data = tabela_kmet_gosp)

tabela_kmet_eko_gosp <- dt[Kmetije == "Kmetijska gospodarstva z ekoloskim kmetovanjem"]
tabela_kmet_eko_gosp$Kmetije <- NULL
tabela_kmet_eko_gosp <- as.data.frame(tabela_kmet_eko_gosp)
tabela_kmet_eko_gosp$leto <- as.numeric(as.character(tabela_kmet_eko_gosp$leto))
tabela_kmet_eko_gosp_lm <- lm(formula = stevilo ~ leto, data = tabela_kmet_eko_gosp)

nova_leta <- data.frame(leto=seq(2017,2022,1))

napoved <- mutate(nova_leta, n=predict(tabela_kmet_gosp_lm, nova_leta))
colnames(napoved) <- c("leto", "stevilo")
napoved$Kmetije <- "Kmetijska gospodarstva"

napoved_eko <- mutate(nova_leta, n=predict(tabela_kmet_eko_gosp_lm, nova_leta))
colnames(napoved_eko) <- c("leto", "stevilo")
napoved_eko$Kmetije <- "Kmetijska gospodarstva z ekoloskim kmetovanjem"

nov_data_napoved <- merge(napoved, napoved_eko, all = TRUE)
nov_data_napoved_cela <- merge(nov_data_napoved, dt, all = TRUE)

nov_data_napoved_cela <- nov_data_napoved_cela[seq_len(nrow(nov_data_napoved_cela)) + c(1,-1),]

#Svet
nova_leta_svet <- data.frame(Year=seq(2018,2023,1))

tabela_Svet <- Tabela_svet %>% filter(Area == "Svet")
tabela_Svet$Area <- NULL
tabela_Svet <- as.data.frame(tabela_Svet)
tabela_Svet_lm <- lm(formula = Value ~ Year, data = tabela_Svet)
napoved_Svet <- mutate(nova_leta_svet, n=predict(tabela_Svet_lm, nova_leta_svet))
colnames(napoved_Svet) <- c("Year", "Value")
napoved_Svet$Area <- "Svet"

tabela_Afrika <- Tabela_svet %>% filter(Area == "Afrika")
tabela_Afrika$Area <- NULL
tabela_Afrika <- as.data.frame(tabela_Afrika)
tabela_Afrika_lm <- lm(formula = Value ~ Year, data = tabela_Afrika)
napoved_Afrika <- mutate(nova_leta_svet, n=predict(tabela_Afrika_lm, nova_leta_svet))
colnames(napoved_Afrika) <- c("Year", "Value")
napoved_Afrika$Area <- "Afrika"

tabela_Amerika <- Tabela_svet %>% filter(Area == "Amerika")
tabela_Amerika$Area <- NULL
tabela_Amerika <- as.data.frame(tabela_Amerika)
tabela_Amerika_lm <- lm(formula = Value ~ Year, data = tabela_Amerika)
napoved_Amerika <- mutate(nova_leta_svet, n=predict(tabela_Amerika_lm, nova_leta_svet))
colnames(napoved_Amerika) <- c("Year", "Value")
napoved_Amerika$Area <- "Amerika"

tabela_Azija <- Tabela_svet %>% filter(Area == "Azija")
tabela_Azija$Area <- NULL
tabela_Azija <- as.data.frame(tabela_Afrika)
tabela_Azija_lm <- lm(formula = Value ~ Year, data = tabela_Afrika)
napoved_Azija <- mutate(nova_leta_svet, n=predict(tabela_Azija_lm, nova_leta_svet))
colnames(napoved_Azija) <- c("Year", "Value")
napoved_Azija$Area <- "Azija"

tabela_Evropa <- Tabela_svet %>% filter(Area == "Evropa")
tabela_Evropa$Area <- NULL
tabela_Evropa <- as.data.frame(tabela_Evropa)
tabela_Evropa_lm <- lm(formula = Value ~ Year, data = tabela_Evropa)
napoved_Evropa <- mutate(nova_leta_svet, n=predict(tabela_Evropa_lm, nova_leta_svet))
colnames(napoved_Evropa) <- c("Year", "Value")
napoved_Evropa$Area <- "Evropa"

tabela_Oceanija <- Tabela_svet %>% filter(Area == "Oceanija")
tabela_Oceanija$Area <- NULL
tabela_Oceanija <- as.data.frame(tabela_Oceanija)
tabela_Oceanija_lm <- lm(formula = Value ~ Year, data = tabela_Oceanija)
napoved_Oceanija <- mutate(nova_leta_svet, n=predict(tabela_Oceanija_lm, nova_leta_svet))
colnames(napoved_Oceanija) <- c("Year", "Value")
napoved_Oceanija$Area <- "Oceanija"

nova_tabela_svet <- Reduce(function(x, y) merge(x,y,all=TRUE),
                           list(napoved_Svet, napoved_Afrika, napoved_Amerika, napoved_Azija, napoved_Evropa, napoved_Oceanija))
Tabela_svet_napoved <- merge(nova_tabela_svet, Tabela_svet, all=TRUE)


# Working with date time objects
# Start date for R is 1st January 1970

# Get the current date: today
today <- Sys.Date()

# See what today looks like under the hood
unclass(today)

# Get the current time: now
now <- Sys.time()

# See what now looks like under the hood
unclass(now)

# 1. Create and format dates
# %Y: 4-digit year (1982)
# %y: 2-digit year (82)
# %m: 2-digit month (01)
# %d: 2-digit day of the month (13)
# %A: weekday (Wednesday)
# %a: abbreviated weekday (Wed)
# %B: month (January)
# %b: abbreviated month (Jan)

# Definition of character strings representing dates
str1 <- "May 23, '96"
str2 <- "2012-03-15"
str3 <- "30/January/2006"

# Convert the strings to dates: date1, date2, date3 - as.Date(): create the date variable
date1 <- as.Date(str1, format = "%b %d, '%y")
date2 <- as.Date(str2, format = "%Y-%m-%d")
date3 <- as.Date(str3, format = "%d/%B/%Y")

# Convert dates to formatted strings - format(): convert dates to character strings
format(date1, "%A")
format(date2, "%d")
format(date3, "%b %Y")

# 2. Create and format times
# %H: hours as a decimal number (00-23)
# %I: hours as a decimal number (01-12)
# %M: minutes as a decimal number
# %S: seconds as a decimal number
# %T: shorthand notation for the typical format %H:%M:%S
# %p: AM/PM indicator
# ?strptime: query this for a full list of symbols

# Definition of character strings representing times
str1 <- "May 23, '96 hours:23 minutes:01 seconds:45"
str2 <- "2012-3-12 14:23:08"

# Convert the strings to POSIXct objects: time1, time2
time1 <- as.POSIXct(str1, format = "%B %d, '%y hours:%H minutes:%M seconds:%S")
time2 <- as.POSIXct(str2, format = "%Y-%m-%d %H:%M:%S")

# Convert times to formatted strings
format(time1, "%M")
format(time2, "%I:%M %p")

# 3. Calculations with Dates
# day1, day2, day3, day4 and day5 are already available in the workspace

# Difference between last and first pizza day
day5 - day1

# Create vector pizza
pizza <- c(day1, day2, day3, day4, day5)

# Create differences between consecutive pizza days: day_diff
day_diff <- diff(pizza)

# Average period between two consecutive pizza days
mean(day_diff)

# 4. Calculations with Times
# login and logout are already defined in the workspace
# Calculate the difference between login and logout: time_online
time_online <- logout - login

# Inspect the variable time_online
time_online

# Calculate the total time online
sum(time_online)

# Calculate the average time online
mean(time_online)

# 5. Differences
# Convert astro to vector of Date objects: astro_dates
astro_dates <- as.Date(astro, format = "%d-%b-%Y")

# Convert meteo to vector of Date objects: meteo_dates
meteo_dates <- as.Date(meteo, format = "%B %d, %y")

# Calculate the maximum absolute difference between astro_dates and meteo_dates
max(abs(astro_dates - meteo_dates))


library(RQuantLib)
library(microbenchmark)

from <- as.Date("2015-06-29")
to <- as.Date("2100-12-20")

microbenchmark ( businessDaysBetween("Brazil", from, to) )

from_vect <- rep(from, 1000000)
to_vect <- rep(to, 1000000)

microbenchmark( businessDaysBetween("Brazil", from_vect, to_vect), times=1)


# This function is intended to simulate random drift of 4 alleles in a population, given starting and ending
# frequencies for each allele, by resampling population of given allele frequency.
# Revision of a script by Melissa Hardstone (FourAlleleDrift.r), reviewed and minor edits JCF 2018.
# The MH copy of FourAlleleDrift.r script HAS AN ERROR- in the reporting of results for A2 and can give incorrect results.
# What I changed:
    #
    # Results were previously only kept for current simulation, I routed them to a larger matrix that stores
    #      results for all sims during function. If raw simulation data is desired, default "raw_data=FALSE" can
    #      be changed to true and all data will be returned. (Good for making sure everything is working as intended,
    #      and plotting if desired.)
    # Also quieted down the function a bit, there were unnecessary print commands everywhere.
    # Added comments for clarity

# last edit: 2019-1-8 JCF

# R sessionInfo of last edit.
# > sessionInfo()
# R version 3.5.1 (2018-07-02)
# Platform: x86_64-w64-mingw32/x64 (64-bit)
# Running under: Windows >= 8 x64 (build 9200)
#
# Matrix products: default
#
# locale:
#   [1] LC_COLLATE=English_United States.1252  LC_CTYPE=English_United States.1252    LC_MONETARY=English_United States.1252
# [4] LC_NUMERIC=C                           LC_TIME=English_United States.1252
#
# attached base packages:
#   [1] stats     graphics  grDevices utils     datasets  methods   base
#
# loaded via a namespace (and not attached):
#   [1] compiler_3.5.1 tools_3.5.1

#
# Input:
#
# SIMS is # simulations desired
# gens is # generations between starting & ending allele frequencies
# size_of_pop is # of diploid individuals in the population
# A1-A4 are starting allele frequencies
# A1-A4 are starting allele frequencies

#
# Output:
#
# Vector of 4 p-values (1 for each allele), calculated as the number of simulations where the allele frequency change is as extreme as the
#         observed allele frequency change. Null hypothesis here is that allele frequency change could be due to drift.
# raw_data is set to FALSE as default, but if set to TRUE function will return a matrix

FourAlleleDrift<-function(SIMS, gens, size_of_pop, A1, A2, A3, A4, end_A1, end_A2, end_A3, end_A4, raw_data=FALSE)
{

  # Set up 4 matrices to track allele frequency over gens (dimensions #gens X #sims)
  # Fill first row with the starting allele frequency
	resultA1<-matrix(NA, nrow=gens, ncol=SIMS)                    # Declare results matrix
	resultA1[1,]=A1                                               # Fill first row with the starting allele frequency
	resultA2<-matrix(NA, nrow=gens, ncol=SIMS)
	resultA2[1,]=A2
	resultA3<-matrix(NA, nrow=gens, ncol=SIMS)
	resultA3[1,]=A3
  resultA4<-matrix(NA, nrow=gens, ncol=SIMS)
  resultA4[1,]=A4

  # Now will loop through SIMS (j) & generations (i)
  #
	for (j in 1:SIMS)                                              # For each of j simulations
	{

    gen<-gens                                                    # no. of generations
		pop_size<-size_of_pop                                        # size_of_pop
		i=1                                                          # Initialize for generation

		# starting with the inputed allele frequencies
		A1_allele<-A1                                                # A1 start freq
		A2_allele<-A2                                                # A2 start freq
		A3_allele<-A3                                                # A3 start freq
		A4_allele<-A4                                                # A4 start freq

		# Create a population with the starting allele frequencies (*2 for diploid)
		pop_alleles<-c( rep('A1',2*pop_size*A1_allele), rep('A2',2*pop_size*A2_allele),
		                rep('A3',2*pop_size*A3_allele), rep('A4',2*pop_size*A4_allele) )

		# take a sample with replacement from the whole population to make next generation (panmictic, random mating)
		pop_alleles<-sample( pop_alleles, 2*pop_size, replace=TRUE )

		# Add the simulated allele frequency to results matrices: find # of entries in pop_alleles for each allele & divide by 2*pop_size
		resultA1[i+1,j]<-( length(pop_alleles[pop_alleles=='A1']) )/(2*pop_size)   # freq of A1 allele, add to results matrix
		resultA2[i+1,j]<-( length(pop_alleles[pop_alleles=='A2']) )/(2*pop_size)   # freq of A2 allele
		resultA3[i+1,j]<-( length(pop_alleles[pop_alleles=='A3']) )/(2*pop_size)   # freq of A3 allele
		resultA4[i+1,j]<-( length(pop_alleles[pop_alleles=='A4']) )/(2*pop_size)   # freq of A4 allele

    # each loop, allele freq ending from previous loop used as the start allele freq
		for(i in 2:gen-1)
		{
		  A1_allele<-resultA1[(i+1)-1,j]                                           # uses A1 freq from last generation
			A2_allele<-resultA2[(i+1)-1,j]                                           # uses new A2 freq
			A3_allele<-resultA3[(i+1)-1,j]                                           # uses new A3 freq
			A4_allele<-resultA4[(i+1)-1,j]                                           # uses new A4 freq

      # Simulate population with new allele frequencies
      pop_alleles<-c(rep('A1',2*pop_size*A1_allele),rep('A2',2*pop_size*A2_allele),rep('A3',2*pop_size*A3_allele),rep('A4',2*pop_size*A4_allele));

			# take a sample from the whole population to make next generation
      pop_alleles<-sample(pop_alleles,2*pop_size,replace=TRUE)
      resultA1[i+1,j]<-(length(pop_alleles[pop_alleles=='A1']))/(2*pop_size)   # freq of A1 allele, add to results matrix
      resultA2[i+1,j]<-(length(pop_alleles[pop_alleles=='A2']))/(2*pop_size)   # freq of A2 allele
      resultA3[i+1,j]<-(length(pop_alleles[pop_alleles=='A3']))/(2*pop_size)   # freq of A3 allele
      resultA4[i+1,j]<-(length(pop_alleles[pop_alleles=='A4']))/(2*pop_size)   # freq of A4 allele

	  }

	}

  # Now have full matrix of results for each allele.
  # Now calculate p-values from simulation results.

  # count times A1 allele freq at generation of interest is equal to or more extreme than obs freq
    # need to designate which direction of the extreme values is wanted
    if(end_A1 < A1)
    {
		  A1_p<-length( which( resultA1[gen,] <= end_A1 ) )/SIMS;
		  #cat("probability of getting end A1 freq or smaller is", A1_p, '\n');
	 }else{
	   A1_p<-length( which( resultA1[gen,] >= end_A1 ) )/SIMS;
		  #cat("probability of getting end A1 freq or larger is", A1_p, '\n');
	 }

 	# Count times A2 allele freq at generation of interest is equal to or more extreme than obs freq
	# Need to designate which direction of the extreme values is wanted
  if(end_A2 < A2)
  {
   A2_p<-length( which( resultA2[gen,] <= end_A2 ) )/SIMS;
    # cat("probability of getting end A2 freq or smaller is", A2_p, '\n');
  }else{
    A2_p<-length( which( resultA2[gen,] >= end_A2 ) )/SIMS;
    # cat("probability of getting end A2 freq or larger is", A2_p, '\n');
  }

	# count times A3 allele freq at generation of interest is equal to or more extreme than obs freq
	# need to designate which direction of the extreme values is wanted
  if(end_A3 < A3)
  {
    A3_p<-length( which( resultA3[gen,] <= end_A3 ) )/SIMS;
    #cat("probability of getting end A3 freq or smaller is", A3_p, '\n');
  }else{
    A3_p<-length( which( resultA3[gen,] >= end_A3 ) )/SIMS;
    #cat("probability of getting end A3 freq or larger is", A3_p, '\n');
  }

	# count times A4 allele freq at generation of interest is equal to or more extreme than obs freq
	# need to designate which direction of the extreme values is wanted
  if(end_A4 < A4)
  {
    A4_p<-length( which( resultA4[gen,] <= end_A4 ) )/SIMS;
    #cat("probability of getting end A4 freq or smaller is", A4_p, '\n');
  }else{
    A4_p<-length( which( resultA4[gen,] >= end_A4 ) )/SIMS;
    #cat("probability of getting end A4 freq or larger is", A4_p, '\n');
  }

  # Function by default returns a vector of 4 p-values, 1 for each allele. Null hypothesis here is that allele frequency change could be due to drift.
  # If raw_data==TRUE, will also return a matrix of simulation results (intended for plotting).

  # Create vector of p-values
  p.vals=c(A1_p,A2_p,A3_p,A4_p)

  if( raw_data==TRUE ){
    print( list("A1_results"=resultA1, "A2_results"=resultA2, "A3_results"=resultA3, "A4_results"=resultA4, p.vals) )
  } else { print(p.vals) }

}


#writes auto.ARIMA model for all seq (4449)

rm(list=ls())
sunflower<-list.files("C:\\kindle_patrika\\jugnu_bholu\\")

library(forecast)  #loading for auto.arima

zangid<-NULL #for appending

for(ambada in sunflower){
inkar<-read.table(paste("C:\\kindle_patrika\\jugnu_bholu\\",ambada,sep=""),skip=1)
shukrana<-substr(ambada,1,nchar(ambada)-4)  #file name
krantivir<-auto.arima( ts(inkar$V1) )       #Auto Arima function

auto_arima_p<-length(krantivir$model$phi)  #p-value
auto_arima_q<-length(krantivir$model$theta)   #q-value
auto_arima_aicc<-krantivir$aicc   #aicc value

sanghmitra<-cbind(shukrana,auto_arima_p,auto_arima_q,auto_arima_aicc,deparse.level=0)
zangid<-rbind(zangid,sanghmitra)

}

write.table(zangid,"C:\\Users\\msc2\\Desktop\\Halwa\\BADMASHI\\Model\\Auto_ARIMA\\Auto_arima_all_gumshuda.txt",col.names=c("PDB_id","Auto_arima_P","Auto_arima_Q","Auto_arima_AICC"),row.names=F)


## Experiments using turn level features

source("../scripts/collate-word-feats.r")
load("word.pros.dt")
load("../results/xprospn.dt")

turn.pros <- get.turn.pros(word.pros)
rs.pros <- get.rs.pros(word.pros, turn.pros)

## D v I experiments?
xrs <- get.rspros.data(rs.pros[rstype %in% c("D","I")], xprospn)
save(xrs, file="xrs")
xrs.params.all <- train.test.turn(xrs)
save(xrs.params.all, file="xrs.params.all")

rsp.feats <- names(xrs.params.all[["x0.data"]])
print(rsp.feats)

rsp.feats <- rsp.feats[!(rsp.feats %in% c("pdur","ndur","pgap","ngap"))]
rsp.feats <- grep("^d[pn]", rsp.feats, invert=T, value=T)

rsp.pred.all <- pred.tune(xrs.params.all, feats=rsp.feats, outfile="pred.rsp.all", downsample=F)
fs.rsp.all <- get.fs.pred(xrs.params.all, feats=rsp.feats, outfile="fs.rsp.all", downsample=F)

## only F0 and Intensity features
#pcontext <- rsp.feats[grep("(F0|I0)",rsp.feats)]
#rsp.pred.pcontext <- pred.tune(xrs.params.all, feats=pcontext, outfile="pred.rsp.pcontext")
#fs.rsp.pcontext <- get.fs.pred(xrs.params.all, feats=pcontext, outfile="fs.rsp.pcontext")

## F0 and Int, no context
pros <- rsp.feats[grep("(F0|I0)",rsp.feats)]
rsp.pred.pros <- pred.tune(xrs.params.all, feats=pros, outfile="pred.rsp.pros", downsample=F)
fs.rsp.pros <- get.fs.pred(xrs.params.all, feats=pros, outfile="fs.rsp.pros", downsample=F)

sigpros <- c("range.normF0")
rsp.pred.sigpros <- pred.tune(xrs.params.all, feats=sigpros, outfile="pred.rsp.sigpros", downsample=F)

#lex <- grep("^n\\.", rsp.feats, value=T)
#rsp.pred.lex <- pred.tune(xrs.params.all, feats=lex, outfile="pred.rsp.lex")
#fs.rsp.lex <- get.fs.pred(xrs.params.all, feats=lex, outfile="fs.rsp.lex")
#
#nonlex <- grep("^n\\.", rsp.feats, value=T, invert=T)
#rsp.pred.nonlex <- pred.tune(xrs.params.all, feats=nonlex, outfile="pred.rsp.nonlex")
#fs.rsp.nonlex <- get.fs.pred(xrs.params.all, feats=nonlex, outfile="fs.rsp.nonlex")

############################################################################
### only Intensity features
#pi0 <- rsp.feats[grep("I0",rsp.feats)]
#rsp.pred.pi0 <- pred.tune(xrs.params.all, feats=pi0, outfile="pred.rsp.pi0")
#
### only F0
#pf0 <- rsp.feats[grep("F0",rsp.feats)]
#rsp.pred.pf0 <- pred.tune(xrs.params.all, feats=pf0, outfile="pred.rsp.pf0")
#fs.rsp.pf0 <- get.fs.pred(xrs.params.all, feats=pf0, outfile="fs.rsp.pf0")
#
### only Intensity features
#ti0 <- pros[grep("I0",pros)]
#rsp.pred.ti0 <- pred.tune(xrs.params.all, feats=ti0, outfile="pred.rsp.ti0")
#
### only F0
#tf0 <- pros[grep("F0",pros)]
#rsp.pred.tf0 <- pred.tune(xrs.params.all, feats=tf0, outfile="pred.rsp.tf0")
#fs.rsp.tf0 <- get.fs.pred(xrs.params.all, feats=tf0, outfile="fs.rsp.tf0")
#
###########################################################################
# Models
###########################################################################

m.rsp <- glmer(is.rs ~  (1 | spk)
		+ to.zscore(mean.normF0) + to.zscore(mean.normI0)
		+ to.zscore(range.normF0) + to.zscore(range.normI0)
		+ to.zscore(slope.normF0) + to.zscore(slope.normI0)
		+ to.zscore(intern.pause)
		+ to.zscore(abs(dur))
		, data=xrs,  family = binomial(link = "logit"))

xtable(get.fixef(m.rsp, roundval=2))


#RevHelper model

#loading the library
library(randomForest)
library(caTools)
library(e1071)
library(caret)

#capture the data
traindata=read.table(file="path/to/modeldata-training-and-testing.txt", header=TRUE)
testdata=read.table(file="path/to/model-validation-data.txt", header=TRUE)

#replacing the NA values
traindata=na.omit(traindata)
testdata=na.omit(testdata)

#initializing the performance
sumAcc=0
sumPosPrec=0
sumPosRec=0
sumNegPrec=0
sumNegRec=0
sumImp=0

#now test performance with 10 different models
for(i in 200:209){

  #setting seeds for different randomization
  set.seed(i)

  #shuffling the data
  sampleddata=cleandata[sample(nrow(traindata), nrow(traindata)), ]

  summary(sampleddata)

  #summary of train and test data
  #summary(sampleddata)
  #summary(testdata)

  #developing RevHelper model -RF fir
  fit <- randomForest(as.factor(className) ~
                        .,
                      data=sampleddata,
                      importance=TRUE,
                      ntree=2000)

  #accumulating the importance
  imp=importance(fit)
  sumImp =sumImp + imp

  #prediction model
  Prediction <- predict(fit, testdata)

  #calculating the performance
  cm=confusionMatrix(data=Prediction,
                     reference=testdata$class,
                     positive='u')

  sumAcc = sumAcc+  cm$overall['Accuracy']
  sumPosPrec=sumPosPrec+ cm$byClass['Pos Pred Value']
  sumPosRec=sumPosRec + cm$byClass['Sensitivity']
  sumNegPrec=sumNegPrec + cm$byClass['Neg Pred Value']
  sumNegRec=sumNegRec + cm$byClass['Specificity']

  #showing model performance for each run
  print(c(cm$byClass['Pos Pred Value'],cm$byClass['Sensitivity'],cm$byClass['Neg Pred Value'],cm$byClass['Specificity'],cm$overall['Accuracy']) )

}

#showing the average performance
print(sumPosPrec/10)
print(sumPosRec/10)
print(sumNegPrec/10)
print(sumNegRec/10)
print(sumAcc/10)
myImp=sumImp/10
print(myImp)


## functions for analyzing patterns of diversity and covariate effects
## covers everything including
## calculations
## plots
#
#
#
## plot of diversity through time compared to mean estimated from posterior
## lots of io but puts out a plot
#plot_divtime <- function(shelly, type, brks, vert) {
#  midpoint <- apply(brks, 1, mean)
#  # plot up unit div through time vs our estimate of average
#  cc <- list()
#  for(ii in seq(length(shelly))) {
#    load(paste0('../data/data_dump/diversity_image_',
#                shelly[ii], '_', type, '.rdata'))
#    cc[[ii]] <- data.frame(x = standata$t, y = standata$y, g = shelly[ii])
#  }
#  cc <- Reduce(rbind, cc)
#  # put in terms of Mya
#  cc$x <- mapvalues(cc$x, sort(unique(cc$x)), midpoint)
#
#  cg <- ggplot(cc, aes(x = x, y = y))
#  cg <- cg + geom_hline(yintercept = 0, colour = 'darkgrey')
#  cg <- cg + geom_vline(xintercept = vert, alpha = 0.5, linetype = 'dashed')
#  cg <- cg + geom_vline(xintercept = 443.8, alpha = 0.5, linetype = 'dotdash')
#  cg <- cg + geom_count(alpha = 0.5,
#                        position = position_jitter(width = 0.1, height = 0))
#  cg <- cg + facet_grid(g ~ .)
#
#  mean.time <- get_postpredstat(shelly, type, nsim, mean)
#  mean.time <- purrr::reduce(mean.time, rbind)
#
#  by.time <- group_by(mean.time, time, g)
#
#  time.mean <- summarise(by.time, mean = mean(est),
#                         low = quantile(est, 0.1),
#                         high = quantile(est, 0.9))
#
#  # put in terms of Mya
#  time.mean$time <- mapvalues(time.mean$time,
#                              sort(unique(time.mean$time)),
#                              midpoint)
#  cg <- cg + geom_pointrange(data = time.mean,
#                             mapping = aes(x = time, y = mean,
#                                           ymin = low, ymax = high),
#                             colour = 'blue', size = 1,
#                             fatten = 1.5, alpha = 0.75)
#  cg <- cg + scale_x_reverse()
#  cg <- cg + labs(x = 'Time (Mya)', y = 'geological unit diversity')
#  cg
#}
#
#
#
## covariates through time
#plot_covtime <- function(shelly, type, brks, covname, vert, violin = FALSE) {
#  # covariate effects
#  out <- out2 <- list()
#  for(ii in seq(length(shelly))) {
#    post <- read_mcmcout(shelly[ii], type)
#
#    # violins
#    mm <- melt(post$beta)
#    mm[, 3] <- mapvalues(mm[, 3], unique(mm[, 3]), covname)
#    names(mm) <- c('iter', 'time', 'covariate', 'value')
#    mm$g <- shelly[ii]
#
#
#    # point range
#    betamean <- apply(post$beta, 2:3, mean)
#    betalow <- apply(post$beta, 2:3, function(x) quantile(x, 0.1))
#    betahigh <- apply(post$beta, 2:3, function(x) quantile(x, 0.9))
#    betaest <- list(betamean, betalow, betahigh)
#    betaest <- llply(betaest, function(x) {
#                       colnames(x) <- covname
#                       x})
#
#    betaest <- llply(betaest, melt)
#    betaest <- data.frame(betaest[[1]],
#                          low = betaest[[2]]$value,
#                          high = betaest[[3]]$value,
#                          g = shelly[ii])
#    names(betaest)[1:2] <- c('time', 'covariate')
#
#    midpoint <- apply(brks, 1, mean)
#    betaest$time <- mapvalues(betaest$time,
#                              sort(unique(betaest$time)),
#                              midpoint)
#    mm$time <- mapvalues(mm$time, sort(unique(mm$time)), midpoint)
#
#    out[[ii]] <- betaest
#    out2[[ii]] <- mm
#  }
#  betaest <- Reduce(rbind, out)
#  betaviol <- Reduce(rbind, out2)
#  betaviol$covariate <- factor(betaviol$covariate,
#                               levels = levels(betaest$covariate))
#  betaviol <- betaviol %>%
#    group_by(covariate, g, time) %>%
#    dplyr::mutate(p = sum(value > 0) / length(value)) %>%
#    ungroup()
#
#  mg <- ggplot(betaest, aes(x = time, y = value))
#  mg <- mg + geom_hline(yintercept = 0, colour = 'darkgrey')
#  mg <- mg + geom_vline(xintercept = vert, alpha = 0.5, linetype = 'dashed')
#  mg <- mg + geom_vline(xintercept = 443.8, alpha = 0.5, linetype = 'dotdash')
#  mg <- mg + geom_pointrange(mapping = aes(ymin = low, ymax = high), fatten = 2)
#  mg <- mg + facet_grid(g ~ covariate, scales = 'free_y')
#  mg <- mg + scale_x_reverse()
#  mg <- mg + scale_fill_distiller(name = 'Probability > 0',
#                                  palette = 'RdBu', limits = c(0, 1))
#  mg <- mg + scale_colour_distiller(name = 'Probability > 0',
#                                    palette = 'RdBu', limits = c(0, 1))
#  mg <- mg + labs(x = 'Time (Mya)', y = 'estimated regression coefficient')
#
#  if(violin) {
#    mg <- mg + geom_violin(data = betaviol,
#                           mapping = aes(x = time, y = value, group = time,
#                                         fill = p, colour = p),
#                           alpha = 0.5)
#  }
#
#  mg
#}
#
#
## look at differences in effects through time
#plot_diffbeta <- function(shelly, type, covname) {
#
#  get_diffbeta <- function(x, cova = 1) {
#    dd <- dim(x)
#    ds1 <- seq(dd[2] - 1)
#    ds2 <- ds1 + 1
#
#    nc <- seq(length(ds1))
#    o <- purrr::map(nc, ~ x[, ds1[.x], cova] - x[, ds2[.x], cova])
#    o
#  }
#  get_covdiff <- function(shelly, type) {
#    out <- list()
#    for(ii in seq(length(shelly))) {
#      post <- read_mcmcout(shelly[ii], type)
#
#      nc <- seq(dim(post$beta)[3])
#      out[[ii]] <- purrr::map(nc, ~ get_diffbeta(post$beta, cova = .x))
#    }
#    names(out) <- shelly
#    out
#  }
#
#  cov_timepairs <- get_covdiff(shelly, type)
#
#  mctp <- melt(cov_timepairs)
#  names(mctp) <- c('value', 'timepair', 'covariate', 'taxon')
#  mctp <- mctp %>%
#    group_by(timepair, covariate, taxon) %>%
#    dplyr::summarize(p = sum(value > 0) / length(value))
#
#  mctp$covariate <- with(mctp, {
#                           plyr::mapvalues(covariate,
#                                           from = unique(covariate),
#                                           to = covname)})
#
#  prsss <- as.character(interaction(seq(from = 1, to = nrow(brks) - 1),
#                                    seq(from = 2, to = nrow(brks))))
#  mctp$timepair <- with(mctp, {
#                          plyr::mapvalues(timepair,
#                                          from = sort(unique(timepair)),
#                                          to = prsss)})
#  mctp$timepair <- factor(mctp$timepair, levels = prsss)
#
#  # value, time pair, covariate, taxon
#  mctp
#  mct <- ggplot(mctp, aes(x = timepair, y = p, group = taxon)) +
#    geom_line() +
#    geom_hline(yintercept = 0.9, linetype = 'dashed', alpha = 0.25) +
#    geom_hline(yintercept = 0.1, linetype = 'dashed', alpha = 0.25) +
#    facet_grid(taxon ~ covariate) +
#    labs(x = 'time pair', y = 'probability')
#
#  mct
#}
#
#
## covariate effects at the hirnantian
#compare_hirbeta <- function(shelly, type, hirnantian = 445.6, brks) {
#  tc <- which(brks == hirnantian)[1]
#
#  ordprob <- silprob <- list()
#  for(ii in seq(length(shelly))) {
#    post <- read_mcmcout(shelly[ii], type)
#
#    dd <- dim(post$beta) # sim, time, covariate
#    betahir <- post$beta[, tc, ]
#    betaord <- post$beta[, seq(tc - 1), ]
#    betasil <- post$beta[, seq(from = tc + 1, to = dd[2]), ]
#    # which are which?
#
#    # compare to hirnantian
#    op <- sp <- c()
#    for(jj in seq(dd[3])) {
#      # for each covariate
#      # ordovician
#      tisp <- dim(betaord)
#      compa <- purrr::map(seq(tisp[2]), ~ betaord[, .x, jj] > betahir[, jj])
#      op[jj] <- sum(purrr::map_dbl(compa, ~ sum(.x))) / length(betaord[, , jj])
#
#      # silurian
#      tisp <- dim(betasil)
#      compa <- purrr::map(seq(tisp[2]), ~ betasil[, .x, jj] > betahir[, jj])
#      sp[jj] <- sum(purrr::map_dbl(compa, ~ sum(.x))) / length(betasil[, , jj])
#    }
#    ordprob[[ii]] <- op
#    silprob[[ii]] <- sp
#  }
#  names(ordprob) <- names(silprob) <- shelly
#  out <- transpose(list(ordovician = ordprob,
#                        silurian = silprob))
#  out
#}
#
#
#
#plot_diffdiv <- function(shelly, type, nsim, foo = mean, brks) {
#  # simulate from posterior, calculate mean for each time point for each sim
#  mm <- get_postpredstat(shelly, type, nsim, foo)
#
#  #mm <- purrr::reduce(mm, rbind)
#  # g is taxonomic group
#
#  get_diffdiv <- function(x) {
#    xt <- split(x, x$time)
#    nn <- x %>% dplyr::summarize(n = n_distinct(time)) %>% unlist()
#    d1 <- seq(from = 1, to = nn - 1)
#    d2 <- seq(from = 2, to = nn)
#    nc <- seq(length(d1))
#    out <- purrr::map(nc, ~ xt[[d1[.x]]]$est - xt[[d2[.x]]]$est) %>%
#      purrr::map_dbl(., ~ sum(.x > 0) / length(.x))
#
#    out
#  }
#  o <- purrr::map(mm, get_diffdiv)
#
#  # give the times for plotting
#  nn <- nrow(brks)
#  d1 <- seq(from = 1, to = nn - 1)
#  d2 <- seq(from = 2, to = nn)
#  prsss <- as.character(interaction(d1, d2))
#  fp <- purrr::map(o, ~ tibble(p = .x, comp = prsss)) %>%
#    bind_rows(.id = 'taxon')
#
#  fp$taxon <- factor(fp$taxon, levels = unique(shelly))
#  fp$comp <- factor(fp$comp, levels = prsss)
#  fpg <- ggplot(fp, aes(x = comp, y = p, group = taxon)) +
#    geom_line() +
#    geom_hline(yintercept = 0.9, linetype = 'dashed', alpha = 0.25) +
#    geom_hline(yintercept = 0.1, linetype = 'dashed', alpha = 0.25) +
#    facet_grid(taxon ~ .) +
#    labs(x = 'time pair', y = 'probability')
#
#  fpg
#
#}
#
#compare_hirdiv <- function(shelly, type, hirnantian = 445.6,
#                           brks, nsim, foo = mean) {
##compare_hirbeta <- function(shelly, hirnantian = 445.6, brks) {
#  mm <- get_postpredstat(shelly, type, nsim, foo)
#
#  # useful values to have around
#  tc <- which(brks == hirnantian)[1] # the hirnantian
#  dd <- nrow(brks) # time steps
#
#  get_pval <- function(x, divhir) {
#    xs <- split(x, x$time)
#    compa <- purrr::map(xs, ~ .x$est > divhir$est)
#    ca <- purrr::map_dbl(compa, ~ sum(.x))
#    sum(ca) / length(unlist(compa))
#  }
#
#  # use get_pval to get ord vs hir, sil vs hir
#  split_extract <- function(x, tc, dd) {
#    divhir <- x[x$time == tc, ]
#    divord <- x[x$time %in% seq(tc - 1), ]
#    divsil <- x[x$time %in% seq(from = tc + 1, to = dd), ]
#
#    op <- get_pval(divord, divhir)
#    os <- get_pval(divsil, divhir)
#    out <- list(ordovician = op,
#                silurian = os)
#    out
#  }
#
#  # get the (unlabeled) pvalues
#  pv <- purrr::map(mm, ~ split_extract(.x, tc, dd))
#  pv
#}
#
#
#
#
#
## plot all the diversity and effect information that's extracted
#plot_infertests <- function(shelly, type, brks, vert, foo, nsim, covname) {
## diversity
## unit div through time vs estimated div from model
#  dg <- plot_divtime(shelly, type = type, brks, vert = hirnantian)
#  dg <- dg + coord_trans(y = 'sqrt')
#  tn <- paste0('../doc/figure/unitdiv_time_', type, '.png')
#  ggsave(plot = dg, filename = tn, width = 11, height = 8.5)
#
#  # step div
#  # expected unit diversity
#  dg <- plot_diffdiv(shelly, type = type, nsim, foo = mean, brks)
#  tn <- paste0('../doc/figure/unitdiv_diff_', type, '.png')
#  ggsave(plot = dg, filename = tn, width = 11, height = 8.5)
#
#  # p-val of div differences
#  compare_pvals_div <- compare_hirdiv(shelly, type = type,
#                                      hirnantian, brks, nsim, foo = mean)
#
#  # effects
#  # covariate effects through time
#  cg <- plot_covtime(shelly, type = type, brks,
#                     covname = covname, vert = hirnantian)
#  tn <- paste0('../doc/figure/cov_time_', type, '.png')
#  ggsave(plot = cg, filename = tn, width = 11, height = 8.5)
#
#
#  # step differences in coef ests
#  bg <- plot_diffbeta(shelly, type = type, covname)
#  tn <- paste0('../doc/figure/cov_diff_', type, '.png')
#  ggsave(plot = bg, filename = tn, width = 11, height = 8.5)
#
#
#  # p-value of beta hir vs ord, hir vs sil
#  compare_pvals_beta <- compare_hirbeta(shelly, type = type, hirnantian, brks)
#
#
#  # have a plot to think about compare_pvals_*
#  cpdiv <- melt(compare_pvals_div)
#  names(cpdiv) <- c('value', 'time', 'taxon')
#
#  cpbet <- purrr::map(compare_pvals_beta, function(a)
#                      purrr::map(a, ~ tibble(value = .x, covname)))
#  cpbet <- purrr::map(cpbet, ~ bind_rows(.x, .id = 'time')) %>%
#    bind_rows(., .id = 'taxon')
#
#
#  # plot intercept stuff
#  names(cpdiv) <- c('div.value', 'time', 'taxon')
#  names(cpbet) <- c('taxon', 'time', 'cov.value', 'covname')
#
#  toplot <- left_join(cpbet, cpdiv) %>%
#    dplyr::mutate(modifier = interaction(taxon, time))
#
#  tpg <- ggplot(toplot, aes(x = div.value, y = cov.value, colour = taxon)) +
#    geom_point(aes(shape = covname)) +
#    scale_shape_manual(values = c(0, 1, 2, 3, 4,  5, 6)) +
#    geom_abline(intercept = 0, slope = 1) +
#    coord_fixed(ratio = 1, xlim = c(0, 1), ylim = c(0, 1)) +
#    facet_wrap(~ time) +
#    labs(x = 'probability (ord, sil) div > hir div',
#         y = 'probability (ord, sil) est > hir est')
#    tn <- paste0('../doc/figure/compare_pval_', type, '.png')
#    ggsave(plot = tpg, filename = tn, width = 11, height = 8.5)
#}


## This script uses the output of the QC.r & methylationDerivedVariables.r scripts and extends our ASD case control analysis to include an interaction with gender
## Filepaths and sample IDs have been removed for security reasons, therefore it serves as a guide to the analysis only

setwd("")
load("QCed_Data.rda")

crosshyb<-read.csv("/data/Non_iPSYCH_Projects/Minerva/FromEilis/450KAnno/CrossHybridisingProbesPriceORWeksberg.csv", row.names = 1)
probes<-read.csv("/data/Non_iPSYCH_Projects/Minerva/FromEilis/450KAnno/SNPsinProbesAnno.csv", row.names = 1)

## remove cross hybridising probes
remove<-match(crosshyb[,1], rownames(betas))
remove<-remove[which(is.na(remove) != TRUE)]
betas<-betas[-remove,]
## remove SNP probes as not a twin analysis
probes<-probes[row.names(betas),]
betas<-betas[which(probes$Weksburg_CommonSNP_Af_within10bpSBE == "" | probes$Illumina_CommonSNP_Af_within10bpSBE == ""),]

betas<-betas[-grep("rs", rownames(betas)),]

## load cellular composition variables
counts<-read.csv("Analysis/HousemanEstimatedCellCounts.csv", stringsAsFactors = FALSE, row.names = 1)
counts<-counts[match(colnames(betas) ,rownames(counts)),]

### alternatively use smokingScores
scores<-read.csv("Analysis/QC/SmokingScores.csv", stringsAsFactors = FALSE, row.names = 1)
scores<-scores[match(colnames(betas), scores$Basename),]

pheno<-read.csv("", stringsAsFactors = FALSE)
### reformat to match DNA methylation data
pheno.cont<-pheno[,c(22,18,grep("cont", colnames(pheno)))]
pheno.case<-pheno[,c(21,18,grep("case", colnames(pheno)))]
pheno.cont<-cbind(pheno.cont, "Con")
pheno.case<-cbind(pheno.case, "Case")
colnames(pheno.cont)<-gsub("_cont", "", colnames(pheno.cont))
colnames(pheno.case)<-gsub("_case", "", colnames(pheno.case))
colnames(pheno.cont)[1]<-"participiant_id"
colnames(pheno.case)[1]<-"participiant_id"
colnames(pheno.cont)[13]<-"CasCon"
colnames(pheno.case)[13]<-"CasCon"
pheno<-rbind(pheno.cont,pheno.case)
pheno$participiant_id<-gsub("MMXII_iPSYCH_", "", pheno$participiant_id)
pheno<-pheno[(match(sampleSheet$Sample_Name, pheno$participiant_id)),]
birthMonth<-unlist(strsplit(pheno$fdato, "/"))[seq(from = 2, by = 3, to = 3*nrow(pheno))]
birthMonth<-factor(birthMonth)
birthYear<-unlist(strsplit(pheno$fdato, "/"))[seq(from = 3, by = 3, to = 3*nrow(pheno))]
birthYear<-factor(birthYear)

res<-matrix(data = NA, nrow = nrow(betas), ncol = 15)
colnames(res)<-c("Aut:Females:P-value", "Aut:Females:MeanDiff", "Aut:Females:SE","Aut:Males:P-value", "Aut:Males:MeanDiff", "Aut:Males:SE","Aut:P-value", "Aut:MeanDiff", "Aut:SE", "Gender:P-value", "Gender:MeanDiff", "Gender:SE", "Int:P-value", "Int:MeanDiff", "Int:SE")
rownames(res)<-rownames(betas)

for(i in 1:nrow(betas)){
	model<-lm(betas[i,] ~ as.factor(sampleSheet$CaCo) + as.factor(sampleSheet$Sentrix_ID) + counts[,1] + counts[,2] + counts[,3] + counts[,4] + counts[,5] + counts[,6] + scores$scores_combined_A + birthMonth + birthYear + as.factor(pheno$geo5) + pheno$gest_week, subset = which(sampleSheet$gender.x.chr == "F"))
	res[i,1:3]<-summary(model)$coefficients["as.factor(sampleSheet$CaCo)Ctrl", c(4,1,2)]

	model<-lm(betas[i,] ~ as.factor(sampleSheet$CaCo)  + as.factor(sampleSheet$Sentrix_ID) + counts[,1] + counts[,2] + counts[,3] + counts[,4] + counts[,5] + counts[,6] + scores$scores_combined_A + birthMonth + birthYear + as.factor(pheno$geo5) + pheno$gest_week, subset = which(sampleSheet$gender.x.chr == "M"))
	res[i,4:6]<-summary(model)$coefficients["as.factor(sampleSheet$CaCo)Ctrl", c(4,1,2)]

	model<-lm(betas[i,] ~ as.factor(sampleSheet$CaCo) + as.factor(sampleSheet$gender.x.chr) + as.factor(sampleSheet$CaCo)*as.factor(sampleSheet$gender.x.chr) + as.factor(sampleSheet$Sentrix_ID) + counts[,1] + counts[,2] + counts[,3] + counts[,4] + counts[,5] + counts[,6] + scores$scores_combined_A + birthMonth + birthYear + as.factor(pheno$geo5) + pheno$gest_week)
	res[i,13:15]<-summary(model)$coefficients["as.factor(sampleSheet$CaCo)Ctrl:as.factor(sampleSheet$gender.x.chr)M", c(4,1,2)]
	res[i,7:9]<-summary(model)$coefficients["as.factor(sampleSheet$CaCo)Ctrl", c(4,1,2)]
	res[i,10:12]<-summary(model)$coefficients["as.factor(sampleSheet$gender.x.chr)M", c(4,1,2)]
}

library(IlluminaHumanMethylation450kanno.ilmn12.hg19)
data(IlluminaHumanMethylation450kanno.ilmn12.hg19)
probeAnnot<-as.data.frame(IlluminaHumanMethylation450kanno.ilmn12.hg19@data$Locations)
probeAnnot<-probeAnnot[rownames(betas),]
res<-cbind(res, probeAnnot)
probeAnnot<-as.data.frame(IlluminaHumanMethylation450kanno.ilmn12.hg19@data$Other)
probeAnnot<-probeAnnot[rownames(betas),]
res<-cbind(res, probeAnnot)

write.csv(res, "Analysis/Aut_InteractionwithGender_wCovariates.csv")


## ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Demographic component functions
##
## x - size this autumn
## y - size next autumn
## S - sex
## A - age
## G - genotype
## Nt - standardised population density
## ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

mk.flist <- function(sets) {
    mydims <- sapply(sets,length)
    mylist <- vector("list", prod(mydims))
    dim(mylist) <- mydims
    dimnames(mylist) <- sets
    return(mylist)
}

## ~~~~~~~~~ SURVIVAL ~~~~~~~~~

p.surv.list <- mk.flist(list(S=c("F","M"), A=c(0,+1)))

p.surv.list[["F", "0"]] <- function(x, Nt, mPar) {
    nu <- mPar["s.a0.F.(Intercept)"]+mPar["s.a0.F.capWgt"]*x+
          mPar["s.a0.F.Nt"]*Nt+mPar["s.a0.F.obsY"]*mPar["obsY"]
    return(invlogit(nu))
}
p.surv.list[["F", "1"]] <- function(x, G, A, Nt, mPar, gSwitch) {
    prefix <- "s.a1.F"
    if (prefix %in% names(gSwitch) & !gSwitch[prefix]) { G = 0 }
    nu <- mPar["s.a1.F.(Intercept)"]+mPar["s.a1.F.capWgt"]*x+
          mPar["s.a1.F.APS071add"]*G+
          mPar["s.a1.F.poly(ageY, 2, raw = TRUE)1"]*A+mPar["s.a1.F.poly(ageY, 2, raw = TRUE)2"]*A^2+
          mPar["s.a1.F.Nt"]*Nt+mPar["s.a1.F.Nt:APS071add"]*G*Nt+mPar["s.a1.F.obsY"]*mPar["obsY"]
    return(invlogit(nu))
}
p.surv.list[["M", "0"]] <- function(x, G, Nt, mPar, gSwitch) {
    prefix <- "s.a0.M"
    if (prefix %in% names(gSwitch) & !gSwitch[prefix]) { G = 0 }
    nu <- mPar["s.a0.M.(Intercept)"]+mPar["s.a0.M.capWgt"]*x+
          mPar["s.a0.M.Nt"]*Nt+mPar["s.a0.M.capWgt:Nt"]*x*Nt+mPar["s.a0.M.obsY"]*mPar["obsY"]+
          mPar["s.a0.M.APS071add"]*G
    return(invlogit(nu))
}
p.surv.list[["M", "1"]] <- function(x, G, A, Nt, mPar, gSwitch) {
    prefix <- "s.a1.M"
    if (prefix %in% names(gSwitch) & !gSwitch[prefix]) { G = 0 }
    nu <- mPar["s.a1.M.(Intercept)"]+mPar["s.a1.M.capWgt"]*x+
          mPar["s.a1.M.APS071add"]*G+mPar["s.a1.M.ageY"]*A+
          mPar["s.a1.M.Nt"]*Nt+mPar["s.a1.M.obsY:APS071add"]*G*mPar["obsY"]+
          mPar["s.a1.M.obsY"]*mPar["obsY"]
    return(invlogit(nu))
}

p.surv <- function(x, G, S, A, Nt, mPar, gSwitch=numeric(0))
{
    ## expect S and A to have length=1
    if (length(S) != 1 | length(A) != 1)
        stop("survival function not vectorised for S(ex) and (A)ge")
    ## assign the required function
    if       (S=="F") {
        if        (A ==  0) {
            f <- p.surv.list[["F", "0"]]
        } else if (A >=  1) {
            f <- p.surv.list[["F", "1"]]
        } else stop("invalid (A)ge")
    } else if (S=="M") {
        if        (A ==  0) {
            f <- p.surv.list[["M", "0"]]
        } else if (A >=  1) {
            f <- p.surv.list[["M", "1"]]
        } else stop("invalid (A)ge")
    } else stop("invalid (S)ex")
    ## get the required arguments as a list of atomic 'names'
    fargs <- names(formals(f))
    fargs <- sapply(fargs, as.name)
    ## call the function and return
    return(do.call("f", fargs))
}

## ~~~~~~~~~ GROWTH ~~~~~~~~~

d.grow.list <- mk.flist(list(S=c("F","M"), A=c(0,+1)))

d.grow.list[["F","0"]] <- function(y, x, Nt, mPar) {
    mu <- mPar["g.a0.F.(Intercept)"]+mPar["g.a0.F.capWgt"]*x+mPar["g.a0.F.Nt"]*Nt
    sg <- mPar["g.a0.F.sigma"]
    return(dnorm(y,mu,sg))
}
d.grow.list[["F","1"]] <- function(y, x, G, A, Nt, mPar) {
    mu <- mPar["g.a1.F.(Intercept)"] + mPar["g.a1.F.capWgt"]*x + mPar["g.a1.F.poly(ageY, 2, raw = TRUE)1"]*A +
          mPar["g.a1.F.Nt"]*Nt + mPar["g.a1.F.ageY:Nt"]*Nt*A + mPar["g.a1.F.poly(ageY, 2, raw = TRUE)2"]*A^2
    sg <- mPar["g.a1.F.sigma"]
    return(dnorm(y,mu,sg))
}
d.grow.list[["M","0"]] <- function(y, x, Nt, mPar) {
    mu <- mPar["g.a0.M.(Intercept)"]+mPar["g.a0.M.capWgt"]*x+mPar["g.a0.M.Nt"]*Nt+mPar["g.a0.M.obsY"]*mPar["obsY"]
    sg <- mPar["g.a0.M.sigma"]
    return(dnorm(y,mu,sg))
}
d.grow.list[["M","1"]] <- function(y, x, G, A, Nt, mPar) {
    mu <- mPar["g.a1.M.(Intercept)"] + mPar["g.a1.M.capWgt"]*x
    sg <- mPar["g.a1.M.sigma"]
    return(dnorm(y,mu,sg))
}

d.grow <- function(y, x, G, S, A, Nt, mPar)
{
    ## expect S and A to have length=1
    if (length(S) != 1 | length(A) != 1)
        stop("growth function not vectorised for S(ex) and (A)ge")
    ## assign the required function
    if       (S=="F") {
        if        (A ==  0) {
            f <- d.grow.list[["F", "0"]]
        } else if (A >=  1) {
            f <- d.grow.list[["F", "1"]]
        } else stop("invalid (A)ge")
    } else if (S=="M") {
        if        (A ==  0) {
            f <- d.grow.list[["M", "0"]]
        } else if (A >=  1) {
            f <- d.grow.list[["M", "1"]]
        } else stop("invalid (A)ge")
    } else stop("invalid (S)ex")
    ## get the required arguments as a list of atomic 'names'
    fargs <- names(formals(f))
    fargs <- sapply(fargs, as.name)
    ## call the function and return
    return(do.call("f", fargs))
}

## ~~~~~~~~~ FEMALE PROBABILITY OF REPRODUCTION ~~~~~~~~~

p.repr.list <- mk.flist(list(A=c(0,+1)))

p.repr.list[["0"]] <- function(x, Nt, mPar) {
    nu <- mPar["r.a0.F.(Intercept)"]+mPar["r.a0.F.capWgt"]*x+
          mPar["r.a0.F.Nt"]*Nt+mPar["r.a0.F.obsY"]*mPar["obsY"]+
          mPar["r.a0.F.capWgt:obsY"]*x*mPar["obsY"]
    return(invlogit(nu))
}
p.repr.list[["1"]] <- function(A, Nt, mPar) {
    nu <- mPar["r.a1.F.(Intercept)"]+
          mPar["r.a1.F.poly(ageY, 2, raw = TRUE)1"]*A+mPar["r.a1.F.poly(ageY, 2, raw = TRUE)2"]*A^2+
          mPar["r.a1.F.obsY"]*mPar["obsY"]+mPar["r.a1.F.ageY:obsY"]*A*mPar["obsY"]
    return(invlogit(nu))
}

p.repr <- function(x, G, A, Nt, mPar)
{
    ## expect S and A to have length=1
    if (length(A) != 1)
        stop("female P(reproduction) function not vectorised for (A)ge")
    ## assign the required function
    if        (A ==  0) {
        f <- p.repr.list[["0"]]
    } else if (A >=  1) {
        f <- p.repr.list[["1"]]
    } else stop("invalid (A)ge")
    ## get the required arguments as a list of atomic 'names'
    fargs <- names(formals(f))
    fargs <- sapply(fargs, as.name)
    ## call the function and return
    return(do.call("f", fargs))
}

## ~~~~~~~~~ FEMALE PROBABILITY OF TWINNING ~~~~~~~~~

p.twin.list <- mk.flist(list(A=c(0,+1)))

p.twin.list[["0"]] <- function(x, Nt, mPar) {
    return(0)
}
p.twin.list[["1"]] <- function(x, A, Nt, mPar) {
    nu <- mPar["t.a1.F.(Intercept)"]+mPar["t.a1.F.capWgt"]*x+
          mPar["t.a1.F.poly(ageY, 2, raw = TRUE)1"]*A+mPar["t.a1.F.poly(ageY, 2, raw = TRUE)2"]*A^2+
          mPar["t.a1.F.Nt"]*Nt+mPar["t.a1.F.obsY"]*mPar["obsY"]
    return(invlogit(nu))
}

p.twin <- function(x, G, A, Nt, mPar)
{
    ## expect S and A to have length=1
    if (length(A) != 1)
        stop("female P(twinning) function not vectorised for (A)ge")
    ## assign the required function
    if        (A ==  0) {
        f <- p.twin.list[["0"]]
    } else if (A >=  1) {
        f <- p.twin.list[["1"]]
    } else stop("invalid (A)ge")
    ## get the required arguments as a list of atomic 'names'
    fargs <- names(formals(f))
    fargs <- sapply(fargs, as.name)
    ## call the function and return
    return(do.call("f", fargs))
}

## ~~~~~~~~~ OFFSPRING SPRING SURVIVAL FUNCTION ~~~~~~~~~

p.offsurv.list <- mk.flist(list(A=c(0,+1), S.off=c("F","M"), T.off=c("0","1")))

p.offsurv.list[["0","F","0"]] <- function(x, Nt, mPar) {
    nu <- mPar["s.off.a0.(Intercept)"]+mPar["s.off.a0.capWgtMum"]*x+
          mPar["s.off.a0.Ntm1"]*Nt+mPar["s.off.a0.obsY"]*mPar["obsY"]
    return(invlogit(nu))
}
p.offsurv.list[["0","M","0"]] <- function(x, Nt, mPar) {
    nu <- mPar["s.off.a0.(Intercept)"]+mPar["s.off.a0.capWgtMum"]*x+
          mPar["s.off.a0.Ntm1"]*Nt+mPar["s.off.a0.obsY"]*mPar["obsY"]+mPar["s.off.a0.sexM"]
    return(invlogit(nu))
}
p.offsurv.list[["1","F","0"]] <- function(x, A, Nt, mPar, isTwn) {
    nu <- mPar["s.off.a1.(Intercept)"]+mPar["s.off.a1.capWgtMum"]*x+
          mPar["s.off.a1.Ntm1"]*Nt+mPar["s.off.a1.obsY"]*mPar["obsY"]
    return(invlogit(nu))
}
p.offsurv.list[["1","M","0"]] <- function(x, A, Nt, mPar, isTwn) {
    nu <- mPar["s.off.a1.(Intercept)"]+mPar["s.off.a1.capWgtMum"]*x+
          mPar["s.off.a1.Ntm1"]*Nt+mPar["s.off.a1.obsY"]*mPar["obsY"]+mPar["s.off.a1.sexM"]
    return(invlogit(nu))
}
p.offsurv.list[["1","F","1"]] <- function(x, A, Nt, mPar, isTwn) {
    nu <- mPar["s.off.a1.(Intercept)"]+mPar["s.off.a1.capWgtMum"]*x+
          mPar["s.off.a1.Ntm1"]*Nt+mPar["s.off.a1.obsY"]*mPar["obsY"]+mPar["s.off.a1.isTwnMat"]
    return(invlogit(nu))
}
p.offsurv.list[["1","M","1"]] <- function(x, A, Nt, mPar, isTwn) {
    nu <- mPar["s.off.a1.(Intercept)"]+mPar["s.off.a1.capWgtMum"]*x+
          mPar["s.off.a1.Ntm1"]*Nt+mPar["s.off.a1.obsY"]*mPar["obsY"]+
          mPar["s.off.a1.sexM"]+mPar["s.off.a1.isTwnMat"]
    return(invlogit(nu))
}

p.offsurv <- function(x, G, A, Nt, mPar, S.off, T.off)
{
    ## expect S and A to have length=1
    if (length(A) != 1)
        stop("offspring survival function not vectorised for (A)ge")
    ## assign the required function
    if        (A == 0) {
        if        (S.off == "F") {
            if        (T.off == 0) {
                f <- p.offsurv.list[["0","F","0"]]
            } else if (T.off == 1) {
                return(0) # age 0 females cannot twin
            } else stop("invalid offspring (T)win status")
        } else if (S.off == "M") {
            if        (T.off == 0) {
                f <- p.offsurv.list[["0","M","0"]]
            } else if (T.off == 1) {
                return(0) # age 0 females cannot twin
            } else stop("invalid offspring (T)win status")
        } else stop("invalid offspring (S)ex")
    } else if (A >= 1) {
        if        (S.off == "F") {
            if        (T.off == 0) {
                f <- p.offsurv.list[["1","F","0"]]
            } else if (T.off == 1) {
                f <- p.offsurv.list[["1","F","1"]]
            } else stop("invalid offspring (T)win status")
        } else if (S.off == "M") {
            if        (T.off == 0) {
                f <- p.offsurv.list[["1","M","0"]]
            } else if (T.off == 1) {
                f <- p.offsurv.list[["1","M","1"]]
            } else stop("invalid offspring (T)win status")
        } else stop("invalid offspring (S)ex")
    } else stop("invalid (A)ge")
    ## get the required arguments as a list of atomic 'names'
    fargs <- names(formals(f))
    fargs <- sapply(fargs, as.name)
    ## call the function and return
    return(do.call("f", fargs))
}

## ~~~~~~~~~ OFFSPRING SIZE DISTRIBUTION ~~~~~~~~~

d.offsize.list <- mk.flist(list(S.off=c("F","M"), T.off=c("0","1")))

d.offsize.list[["F","0"]] <- function(y, x, A, Nt, mPar) {
    mu <- mPar["sz.off.(Intercept)"]+mPar["sz.off.capWgtMum"]*x+
          mPar["sz.off.ageMum"]*A+
          mPar["sz.off.Ntm1"]*Nt+
          mPar["sz.off.obsY"]*mPar["obsY"]+
          mPar["sz.off.ageMum:obsY"]*A*mPar["obsY"]
    sg <- mPar["sz.off.sigma"]
    return(dnorm(y,mu,sg))
}
d.offsize.list[["M","0"]] <- function(y, x, A, Nt, mPar) {
    mu <- mPar["sz.off.(Intercept)"]+mPar["sz.off.capWgtMum"]*x+
          mPar["sz.off.ageMum"]*A+
          mPar["sz.off.Ntm1"]*Nt+mPar["sz.off.sexM"]+
          mPar["sz.off.obsY"]*mPar["obsY"]+
          mPar["sz.off.ageMum:obsY"]*A*mPar["obsY"]

    sg <- mPar["sz.off.sigma"]
    return(dnorm(y,mu,sg))
}
d.offsize.list[["F","1"]] <- function(y, x, A, Nt, mPar) {
    mu <- mPar["sz.off.(Intercept)"]+mPar["sz.off.capWgtMum"]*x+
          mPar["sz.off.ageMum"]*A+
          mPar["sz.off.Ntm1"]*Nt+mPar["sz.off.isTwnMat"]+
          mPar["sz.off.obsY"]*mPar["obsY"]+
          mPar["sz.off.ageMum:obsY"]*A*mPar["obsY"]
    sg <- mPar["sz.off.sigma"]
    return(dnorm(y,mu,sg))
}
d.offsize.list[["M","1"]] <- function(y, x, A, Nt, mPar) {
    mu <- mPar["sz.off.(Intercept)"]+mPar["sz.off.capWgtMum"]*x+
          mPar["sz.off.ageMum"]*A+
          mPar["sz.off.Ntm1"]*Nt+mPar["sz.off.sexM"]+mPar["sz.off.isTwnMat"]+
          mPar["sz.off.obsY"]*mPar["obsY"]+
          mPar["sz.off.ageMum:obsY"]*A*mPar["obsY"]
    sg <- mPar["sz.off.sigma"]
    return(dnorm(y,mu,sg))
}

d.offsize <- function(y, x, G, A, Nt, mPar, S.off, T.off)
{
    ## expect S and A to have length=1
    if (length(S.off) != 1 | length(T.off) != 1)
        stop("offspring size function not vectorised for offspring S(ex), female (A)ge and (T)win status")
    ## assign the required function
    if (all(A >= 0)) {
        if        (S.off == "F") {
            if        (T.off == 0) {
                f <- d.offsize.list[["F","0"]]
            } else if (T.off == 1) {
                f <- d.offsize.list[["F","1"]]
            } else stop("invalid offspring (T)win status")
        } else if (S.off == "M") {
            if        (T.off == 0) {
                f <- d.offsize.list[["M","0"]]
            } else if (T.off == 1) {
                f <- d.offsize.list[["M","1"]]
            } else stop("invalid offspring (T)win status")
        } else stop("invalid offspring (S)ex")
    } else stop("invalid (A)ge")
    ## get the required arguments as a list of atomic 'names'
    fargs <- names(formals(f))
    fargs <- sapply(fargs, as.name)
    ## call the function and return
    return(do.call("f", fargs))
}

## ~~~~~~~~~ MALE MATING SUCCESS ~~~~~~~~~

n.mrepro.list <- mk.flist(list(A=c("0","1")))

n.mrepro.list[["0"]] <- function(x, G, Nt, mPar, gSwitch) {
    prefix <- "n.off.a0.M"
    if (prefix %in% names(gSwitch) & !gSwitch[prefix]) { G = 0 }
    nu <- mPar["n.off.a0.M.(Intercept)"] + mPar["n.off.a0.M.capWgt"]*x +
          mPar["n.off.a0.M.APS071add"]*G + mPar["n.off.a0.M.Nt"]*Nt + mPar["n.off.a0.M.obsY"]*mPar["obsY"]
    return(exp(nu))
}
n.mrepro.list[["1"]] <- function(x, G, Nt, mPar, gSwitch) {
    prefix <- "n.off.a1.M"
    if (prefix %in% names(gSwitch) & !gSwitch[prefix]) { G = 0 }
    nu <- mPar["n.off.a1.M.(Intercept)"] + mPar["n.off.a1.M.capWgt"]*x +
          mPar["n.off.a1.M.APS071add"]*G + mPar["n.off.a1.M.APS071add:Nt"]*G*Nt +
          mPar["n.off.a1.M.Nt"]*Nt + mPar["n.off.a1.M.obsY"]*mPar["obsY"]
    return(exp(nu))
}

n.mrepro <- function(x, G, A, Nt, mPar, gSwitch=numeric(0))
{
    ## expect S and A to have length=1
    if (length(A) != 1)
        stop("male reproduction function not vectorised for (A)ge")
    ## assign the required function
    if        (A ==  0) {
        f <- n.mrepro.list[["0"]]
    } else if (A >=  1) {
        f <- n.mrepro.list[["1"]]
    } else stop("invalid (A)ge")
    ## get the required arguments as a list of atomic 'names'
    fargs <- names(formals(f))
    fargs <- sapply(fargs, as.name)
    ## call the function and return
    return(do.call("f", fargs))
}


#!/usr/bin/Rscript

args=commandArgs(TRUE)
options(warn=-1)

RAW=T

if ("pval" %in% args) {
	RAW=F
	if ("qqplot" %in% args) QQ=T
}

LL=function(x,y) sum(dnorm(y,x[1],x[2],log=T))

Pheno.name=unlist(strsplit(args[1],"/"))
Pheno.name=Pheno.name[length(Pheno.name)]
Pheno.name=gsub("GWAlpha_","",Pheno.name)
Pheno.name=gsub("_out.csv","",Pheno.name)

GWAlpha=read.csv(args[1],header=T)
GWAlpha=GWAlpha[!is.na(as.numeric(as.character(GWAlpha[,ncol(GWAlpha)]))),]

if ("2L" %in% GWAlpha[,1]) {
CHR.labs=c("5"="4","1"="2L","2"="2R","3"="3L","4"="3R","6"="X")
GWAlpha=GWAlpha[order(as.character(GWAlpha[,1]),as.numeric(as.character(GWAlpha[,2]))),]
} else {
CHR.labs=unique(as.character(GWAlpha[,1]))
names(CHR.labs)=unique(as.character(GWAlpha[,1]))
GWAlpha=GWAlpha[order(as.character(GWAlpha[,1]),as.numeric(as.character(GWAlpha[,2]))),]
}

OUT=GWAlpha[GWAlpha[,1] %in% CHR.labs,]
CHR=OUT[,1]

for (i in 1:length(CHR.labs)) CHR=gsub(CHR.labs[i],names(CHR.labs)[i],CHR)
CHR.labs=CHR.labs[names(CHR.labs) %in% unique(CHR)]
CHR.labs=CHR.labs[order(names(CHR.labs))]

Position=as.numeric(as.character(OUT[,2]))
CHR.start=vector()
CHR.end=vector()
for (i in unique(CHR)) {
	ID=which(CHR==i)
	CHR.start=c(CHR.start,ID[1])
	CHR.end=c(CHR.end,ID[length(ID)])
}
CHR.summary=cbind(Position[CHR.start],Position[CHR.end])
rownames(CHR.summary)=unique(CHR)

Position.cum=CHR.summary[,2]-CHR.summary[,1]
CHR.cum=0
for (i in 2:length(unique(CHR))) CHR.cum=c(CHR.cum,sum(Position.cum[1:(i-1)]))
names(CHR.cum)=unique(CHR)

Position.cum=vector()
for (i in unique(CHR)) Position.cum=c(Position.cum,Position[which(CHR==i)]+as.numeric(CHR.cum[which(names(CHR.cum)==i)])-1)

CHR.mid=CHR.cum+(c(CHR.cum[-1],max(CHR.cum)+Position[length(Position)])-CHR.cum)/2

CHR=as.numeric(as.factor(CHR))
GWAlpha=as.numeric(as.character(OUT$Alpha))

if (RAW) {
	png(file=gsub("_out.csv",".png",args[1]),width=1200,height=400)
	plot(0,pch='',xlim=c(0,max(Position.cum)),xlab="Chromosome",xaxt='n',ylab=expression(alpha^2),ylim=c(0,max(GWAlpha^2,na.rm=T)),bty="n",las=2,main=Pheno.name)
	axis(side=1,at=CHR.mid[!is.na(names(CHR.mid))],labels=CHR.labs,pos=0)
	points(GWAlpha[CHR %% 2 !=0]^2~Position.cum[CHR %% 2 !=0],pch=20, col="#104E8B")
	points(GWAlpha[CHR %% 2 ==0]^2~Position.cum[CHR %% 2 ==0],pch=20, col="#ADD8E6")
	#abline(v=CHR.cum[!is.na(names(CHR.cum))][-1],col=2,lty=2,ylim=c(0,max(GWAlpha^2,na.rm=T)))
	if (length(GWAlpha)>100)	abline(h=quantile(GWAlpha^2,1-(100/length(GWAlpha))),col=3)
	dev.off()
} else {
	EST=optim(par=c(mu=0,sd=sd(GWAlpha)),fn=LL,y=GWAlpha,control=list(fnscale=-1,reltol=1e-10))$par
	pval=ifelse(pnorm(GWAlpha,EST[1],EST[2]) > 0.5, 2*(1-pnorm(GWAlpha,EST[1],EST[2])), 2*pnorm(GWAlpha,EST[1],EST[2]))
	p_score=-log10(pval)
	png(file=gsub("_out.csv",".png",args[1]),width=1200,height=400)
	plot(0,pch='',xlim=c(0,max(Position.cum)),xlab="Chromosome",xaxt='n',ylab=expression(-log[10](italic(p))),ylim=c(0,max(p_score,na.rm=T)),bty="n",las=2,main=Pheno.name)
	axis(side=1,at=CHR.mid[!is.na(names(CHR.mid))],labels=CHR.labs,pos=0)
	points(p_score[CHR %% 2 !=0]~Position.cum[CHR %% 2 !=0],pch=20, col="#104E8B")
	points(p_score[CHR %% 2 ==0]~Position.cum[CHR %% 2 ==0],pch=20, col="#ADD8E6")
	#abline(v=CHR.cum[!is.na(names(CHR.cum))][-1],col=2,lty=2)
	if (length(GWAlpha)>100)	abline(h=quantile(p_score,1-(100/length(GWAlpha))),col=3)
	dev.off()
	if (QQ) {
		png(file=gsub("_out.csv","_qqplot.png",args[1]),width=1200,height=400)
		p_order=-log10(pval[order(pval,decreasing=T)])
		p_exp=-log10(seq(1,0,length=length(pval)))
		plot(p_order~p_exp,ylab="Observed p-value",xlab="Expected p-value")
		abline(0,1,col=2)
		dev.off()
	}
}


#t_pulse是单次射出所需的时间
#t_pulse，随着电压频率fv的上升而改变；随着流量而改变；

#设定工作目录
setwd("D:/data")
library(xlsx)
 library(RColorBrewer)

#读取数据
s2<-read.xlsx("t_pulse.xls", sheetName = "single_k2", header = TRUE)
s3<-read.xlsx("t_pulse.xls", sheetName = "single_k3", header = TRUE)
s4<-read.xlsx("t_pulse.xls", sheetName = "single_k4", header = TRUE)
s5<-read.xlsx("t_pulse.xls", sheetName = "single_k5", header = TRUE)

#保存数据
#pdf("t_pulse_K_mixed.pdf")

par(mfrow = c(2,2), mar = c(4,4,2,2), oma = c(2,2,2,2))
mycolors <- c("red", "blue", "black", "darkgreen")

##################################画图--占空比k为0.2#######################
plot(s2$fv, s2$X1.5, xaxs = "i", col = 0, xlab = "Voltage frequency (Hz)", ylab = "t_pulse (ms)", main = "k = 0.2", cex.lab = 1, cex.main = 1.3, yaxs = "r", xlim = c(0, 250), ylim = c(0.2, 1))

for (i in 1:4){
points(s2$fv, s2[,i+1],  col=mycolors[i], pch=1, lwd = 2)
}

abline(0.45, -0.00088, lty = 3, col = "red", lwd = 2)
abline(0.8, -0.001, lty = 3, col = "red", lwd = 2)
text(130, 0.8, "0.45ms ~ 0.8ms", col ="blue", cex =1.2, font =2)
text(20, 0.95, "(a)", col ="black", cex =1.2, font =2)

legend("topright", c("1.5nl/min", "27nl/min", "54nl/min", "180nl/min"), col = mycolors, cex = 1, pch =21, bty = "n")

##################################画图--占空比k为0.3#######################
plot(s2$fv, s2$X1.5, xaxs = "i", col = 0, xlab = "Voltage frequency (Hz)", ylab = "t_pulse (ms)", main = "k = 0.3", cex.lab = 1, cex.main = 1.3, yaxs = "r", xlim = c(0, 250), ylim = c(0.2, 1))

for (i in 1:4){
points(s3$fv, s3[,i+1],  col=mycolors[i], pch=1, lwd = 2)
}

abline(0.55, -0.00088, lty = 3, col = "red", lwd = 2)
abline(0.9, -0.001, lty = 3, col = "red", lwd = 2)
text(130, 0.9, "0.55ms ~ 0.9ms", col ="blue", cex =1.2, font =2)
text(20, 0.95, "(b)", col ="black", cex =1.2, font =2)
##################################画图--占空比k为0.4#######################
plot(s2$fv, s2$X1.5, xaxs = "i", col = 0, xlab = "Voltage frequency (Hz)", ylab = "t_pulse (ms)", main = "k = 0.4", cex.lab = 1, cex.main = 1.3, yaxs = "r", xlim = c(0, 250), ylim = c(0.2, 1.6))

for (i in 1:4){
points(s3$fv, s3[,i+1],  col=mycolors[i], pch=1, lwd = 2)
}

abline(0.53, -0.00088, lty = 3, col = "red", lwd = 2)
abline(0.88, -0.001, lty = 3, col = "red", lwd = 2)
text(130, 1, "0.53ms ~ 0.88ms", col ="blue", cex =1.2, font =2)
text(20, 1.5, "(c)", col ="black", cex =1.2, font =2)

legend("topright", c("1.5nl/min", "27nl/min", "54nl/min", "180nl/min"), inset = 0.03, col = mycolors, cex = 1, pch =21, bty = "n")

##################################画图--占空比k为0.5#######################
plot(s2$fv, s2$X1.5, xaxs = "i", col = 0, xlab = "Voltage frequency (Hz)", ylab = "t_pulse (ms)", main = "k = 0.5", cex.lab = 1, cex.main = 1.3, yaxs = "r", xlim = c(0, 250), ylim = c(0.2, 1.8))

for (i in 1:4){
points(s4$fv, s4[,i+1],  col=mycolors[i], pch=1, lwd = 2)
}

abline(0.53, -0.00088, lty = 3, col = "red", lwd = 2)
abline(0.88, -0.001, lty = 3, col = "red", lwd = 2)
text(130, 1, "0.53ms ~ 0.88ms", col ="blue", cex =1.2, font =2)
text(20, 1.7, "(d)", col ="black", cex =1.2, font =2)


#UNIX-------->   calculates autofit(p,q)order/arma model,divides list into stationary & non-stationary

rm(list=ls())
library(itsmr)  #adding itsmr package

#source("C:\\Users\\msc2\\Desktop\\Halwa\\coke pene de\\new_dot_star\\itall.R.txt")  #adding sarima function source code

faana<-"/data/vikas/bin/yeda/"  #file path for r values
madhur<-list.files(faana)

naringi_firangi<-NULL #complete row information for Stationary model
bunty_bubly<-NULL  #for taking all Non-Stationary info

for (sangeet in madhur){

 html_page<-substr(sangeet,1,nchar(sangeet)-4) #name of file
 compendium<- read.table(paste(faana,sangeet,sep=""))
   print(paste("Reading-------------------------------->",html_page))

 #autofit(arma)model  & checking for non stationarity
 j<-NULL
 j<-tryCatch(red_money<-autofit(compendium$V1),error=function(e)e )   #autofit(arma)model (max likelihood method)

 if(inherits(j,"simpleError")){ bunty_bubly<-append(bunty_bubly,html_page);print(paste("Non-Stationary-------------------------->",html_page))}
 else{

 autofit_ar_p<-length(red_money$phi)  #autoregressive p value
 autofit_ma_q<-length(red_money$theta)  #moving average q value
 autofit_aicc<-red_money$aicc   #aicc

 #joining single line
 bumro<-cbind(html_page,autofit_ar_p,autofit_ma_q,autofit_aicc,deparse.level=0)
 naringi_firangi<-rbind(naringi_firangi,bumro)
            } #non-stationary else

}  #last for

#only stationary model
write.table(naringi_firangi,"/data/vikas/bin/Halwa/BADMASHI/Model/ARMA/Autofit_arma_stationary.txt",col.names=c("PDB_file","AutoF_ar_p","AutoF_ma_q","AutoF_aicc"),row.names=F)

#Non-Stationary model
write.table(bunty_bubly,"/data/vikas/bin/Halwa/BADMASHI/Model/ARMA/Autofit_dhak_dhak_non_stat.txt",col.names="Non-Stationary models",row.names=F)