#' Plot annual SPR targets
#'
#' Computes and plots SPR targets using selectivity, M, WAA, and maturity by year.
#' @param asap name of the variable that read in the asap.rdat file
#' @param pspr user defined value(s) of spr, e.g. 0.4 or c(0.4, 0.43, 0.46); if empty (default), calculated at seq(0.2, 0.5, by=0.1)
#' @param save.plots save individual plots
#' @param od output directory for plots and csv files
#' @param plotf type of plot to save
#' @export

PlotAnnualSPRtargets <- function(asap, pspr=c(), save.plots,od,plotf){

  if(length(pspr)>0) spr.targ.values <- pspr
  if(length(pspr)==0) spr.targ.values <- seq(0.2, 0.5, by=0.1)
  n.spr <- length(spr.targ.values)
  nages<- asap$parms$nages
  nyears <- asap$parms$nyears
  years <- seq(asap$parms$styr,asap$parms$endyr)
  fec.age <- asap$WAA.mats$WAA.ssb
  mat.age <- asap$maturity
  wgt.age <- asap$WAA.mats$WAA.catch.all
  M.age <- asap$M.age
  sel.age <- asap$F.age/apply(asap$F.age,1,max)

  spawn.time <- asap$options$frac.yr.spawn

  spr0.vals<- asap$SR.annual.parms$s.per.r.vec
  F.start <-0.11  # starting guess for optimization routine to find F_SPR%

  f.spr.vals <- matrix(NA, nyears, n.spr)
  ypr.spr.vals <- matrix(NA, nyears, n.spr)
  conv.vals <- matrix(NA, nyears, n.spr)

  for (i in 1:n.spr) {
    for (j in 1:nyears) {
      t.spr <- spr.targ.values[i]

      spr.f <- function(F.start) {
        abs(s.per.recr(nages=nages, fec.age=fec.age[j,], mat.age=mat.age[j,], M.age= M.age[j,], F.mult=F.start, sel.age=sel.age[j,], spawn.time=spawn.time)/spr0.vals[j] - t.spr )
      }
      yyy <- nlminb(start=F.start, objective=spr.f, lower=0, upper=3)
      f.spr.vals[j,i] <- yyy$par
      ypr.spr.vals[j,i] <- ypr(nages, wgt.age=wgt.age[j,], M.age=M.age[j,],  F.mult=f.spr.vals[j,i], sel.age=sel.age[j,] )
      conv.vals[j,i] <- ifelse(yyy$convergence==0, TRUE, FALSE)
    }  # end j-loop over nyears
  }  #end i-loop over SPR values

 # if(length(pspr)==0) {
  par(mfrow=c(1,1), mar=c(4,4,2,4) )
  lty.seq=c(1,2,4,6)
  plot(years, f.spr.vals[,1], type='n', xlab="Year", ylab="Full F (%SPR)", lwd=2,
       col="blue3", ylim=c(0,1.2*max(f.spr.vals)) )
  for (i in 1:n.spr) {
    lines(years, f.spr.vals[,i], lwd=2, col=i, lty=lty.seq[i] )
  }
  if(length(pspr)==0) legend('top', legend=c("F20%", "F30%", "F40%", "F50%"), col=seq(1,4), lty=lty.seq,
         horiz=T,lwd=rep(2,4), cex=0.9)
  if(length(pspr)>0) legend('top', legend=c(paste0("F", round(100*pspr,0), "%")), col=seq(1,4), lty=lty.seq,
                             horiz=T,lwd=rep(2,4), cex=0.9)

  title (main="Annual F(%SPR) Reference Points", outer=T, line=-1 )

  if (save.plots) savePlot(paste0(od, "Annual.FSPR.", plotf), type=plotf)

  plot(years, ypr.spr.vals[,1], type='n', xlab="Year", ylab="YPR (%SPR)", lwd=2,
       col="blue3", ylim=c(0,1.2*max(ypr.spr.vals)) )
  for (i in 1:n.spr) {
    lines(years, ypr.spr.vals[,i], lwd=2, col=i, lty=lty.seq[i] )
  }
  if(length(pspr)==0) legend('top', legend=c("YPR20%", "YPR30%", "YPR40%", "YPR50%"), col=seq(1,4), lty=lty.seq,
         horiz=T,lwd=rep(2,4), cex=0.9)
  if(length(pspr)>0) legend('top', legend=c(paste0("YPR", round(100*pspr,0), "%")), col=seq(1,4), lty=lty.seq,
                             horiz=T,lwd=rep(2,4), cex=0.9)

  title (main="Annual YPR(%SPR) Reference Points", outer=T, line=-1 )

  if (save.plots) savePlot(paste0(od, "Annual.YPR.", plotf), type=plotf)

  if(length(pspr)==0) {
  f.hist.20 <- hist(f.spr.vals[,1], plot=F)
  f.hist.30 <- hist(f.spr.vals[,2], plot=F)
  f.hist.40 <- hist(f.spr.vals[,3], plot=F)
  f.hist.50 <- hist(f.spr.vals[,4], plot=F)

  par(mfrow=c(2,2), mar=c(4,4,2,2), oma=c(0,0,2,0) )

  plot(f.hist.20$mids, f.hist.20$counts, xlab="Full F20%", ylab="Frequency", type='h', lwd=2,
       ylim=c(0, max(f.hist.20$counts)), col='blue4'  )
  lines(f.hist.20$mids, f.hist.20$counts, lwd=2, col='blue4')
  plot(f.hist.30$mids, f.hist.30$counts, xlab="Full F30%", ylab="Frequency", type='h', lwd=2,
       ylim=c(0, max(f.hist.30$counts)), col='blue4'  )
  lines(f.hist.30$mids, f.hist.30$counts, lwd=2, col='blue4')
  plot(f.hist.40$mids, f.hist.40$counts, xlab="Full F40%", ylab="Frequency", type='h', lwd=2,
       ylim=c(0, max(f.hist.40$counts)), col='blue4'  )
  lines(f.hist.40$mids, f.hist.40$counts, lwd=2, col='blue4')
  plot(f.hist.50$mids, f.hist.50$counts, xlab="Full F50%", ylab="Frequency", type='h', lwd=2,
       ylim=c(0, max(f.hist.50$counts)), col='blue4'  )
  lines(f.hist.50$mids, f.hist.50$counts, lwd=2, col='blue4')

  title (main="Annual F (%SPR) Reference Points", outer=T, line=-1 )

  if (save.plots) savePlot(paste0(od, "Annual.F_SPR.4panel.hist.", plotf), type=plotf)

  ypr.hist.20 <- hist(ypr.spr.vals[,1], plot=F)
  ypr.hist.30 <- hist(ypr.spr.vals[,2], plot=F)
  ypr.hist.40 <- hist(ypr.spr.vals[,3], plot=F)
  ypr.hist.50 <- hist(ypr.spr.vals[,4], plot=F)

  par(mfrow=c(2,2), mar=c(4,4,2,2), oma=c(0,0,2,0) )

  plot(ypr.hist.20$mids, ypr.hist.20$counts, xlab="YPR (F20%)", ylab="Frequency", type='h', lwd=2,
       ylim=c(0, max(ypr.hist.20$counts)), col='blue4'  )
  lines(ypr.hist.20$mids, ypr.hist.20$counts, lwd=2, col='blue4')
  plot(ypr.hist.30$mids, ypr.hist.30$counts, xlab="YPR (F30%)", ylab="Frequency", type='h', lwd=2,
       ylim=c(0, max(ypr.hist.30$counts)), col='blue4'  )
  lines(ypr.hist.30$mids, ypr.hist.30$counts, lwd=2, col='blue4')
  plot(ypr.hist.40$mids, ypr.hist.40$counts, xlab="YPR (F40%)", ylab="Frequency", type='h', lwd=2,
       ylim=c(0, max(ypr.hist.40$counts)), col='blue4'  )
  lines(ypr.hist.40$mids, ypr.hist.40$counts, lwd=2, col='blue4')
  plot(ypr.hist.50$mids, ypr.hist.50$counts, xlab="YPR (F50%)", ylab="Frequency", type='h', lwd=2,
       ylim=c(0, max(ypr.hist.50$counts)), col='blue4'  )
  lines(ypr.hist.50$mids, ypr.hist.50$counts, lwd=2, col='blue4')

  title (main="Annual YPR (%SPR) Reference Points", outer=T, line=-1 )

  if (save.plots) savePlot(paste0(od, "Annual.YPR_SPR.4panel.hist.", plotf), type=plotf)
  par(mfrow=c(1,1), mar=c(5.1,4.1,4.1,2.1), oma=c(0,0,0,0))
  } # end test if pspr has length 0

  spr.list <- list(f.spr.vals=f.spr.vals, ypr.spr.vals=ypr.spr.vals, conv.vals=conv.vals)
  return(spr.list)
} # end function


## 2. Reading in data ##

congress <- read.csv("114_congress.csv")
whiteHouse = read.csv('2015_white_house.csv')

## 4. Creating a matrix ##

# Create a simple matrix with 3 rows and 2 columns.
B <- matrix(c(1,2,3,4,5,6), 3, 2)
print(B)
C <- matrix(c("Rambo", "Chuck Norris", "Arnold", "Steven Seagal", "John Wayne", "Steve McQueen"), 2, 3)

## 5. Getting a matrix element ##

# Print the first column of the second row.
print(C[2,1])

# Print the third column of the second row.
print(C[2,3])
c22 <- C[2,2]
c13 <- C[1,3]

## 6. Getting rows and columns ##

# The first row of C.
print(C[1,])

# The first column of C.
print(C[,1])
c20 <- C[2,]
c03 <- C[,3]

## 8. Data frame columns ##

# Get the salary column from the whitehouse data
salary <- whiteHouse["Salary"]

# Get the salary of the first employee in our data (salary column of the first row)
firstSalary <- whiteHouse[1,"Salary"]
whiteHouseNames = whiteHouse['Name']
status5 <- whiteHouse[5, 'Status']

## 9. Finding average salary ##

# Enter your code here.
averageSalary <- sum(whiteHouse["Salary"]) / nrow(whiteHouse)

## 10. Finding the highest/lowest salary ##

# Enter your code here.
highestSalary = max(whiteHouse['Salary'])
lowestSalary = min(whiteHouse['Salary'])

## 11. Subtle differences ##

# Returns a data frame.
salaryFrame <- whiteHouse["Salary"]

# Returns a vector
salaryVector <- whiteHouse[,"Salary"]
whiteHouseNames <- whiteHouse["Name"]

whiteHouseNamesVector <- whiteHouse[,"Name"]

## 12. Minimum/maximum index ##

# Find the index of the person with the lowest salary.
# This is where knowing what kind of indexing returns what value comes in handy!  We need a vector.
minimumIndex <- which.min(whiteHouse[,"Salary"])
# Extract the row of the lowest salary.
minimumSalaryRow <- whiteHouse[minimumIndex,]
# Get the name column from that row.
lowestEarner <- minimumSalaryRow["Name"]
# Print the name of the white house employee who earned the least.
print(lowestEarner)
maximumIndex <- which.max(whiteHouse[,"Salary"])
maximumSalaryRow <- whiteHouse[maximumIndex,]
highestEarner <- maximumSalaryRow["Name"]

R Programming Beginner/Matrices and data frames-126.r


dyn.load('/Library/Java/JavaVirtualMachines/jdk1.8.0_131.jdk/Contents/Home/jre/lib/server/libjvm.dylib')
library(rJava)

setwd("/Users/mengmengjiang/all datas/print")

library(xlsx)

# reading ux and sd

k1<-read.xlsx("dotx.xlsx",sheetName="600",header=TRUE)
k2<-read.xlsx("dotx.xlsx",sheetName="1khz",header=TRUE)
k3<-read.xlsx("dotx.xlsx",sheetName="2khz",header=TRUE)
k4<-read.xlsx("dotx.xlsx",sheetName="2.5khz",header=TRUE)

# errorbar
error.bar <- function(x, y, upper, coll,lower=upper, length=0.05,...){
if(length(x) != length(y) | length(y) !=length(lower) | length(lower) != length(upper))
stop("vectors must be same length")
arrows(x,y+upper, x, y-lower,col=coll, angle=90, code=3, length=length, ...)
}

# color setting

yan<-c("red","blue","black","green3")
pcc<-c(0,1,2,5)
pcc1<-c(6,22,23,25)

# plot
par(fig=c(0,1,0,1),new=T)
plot(k1$ux,k1$sdeva, col=0,xlab = expression(italic(U["x"]) (mm/s)),
          ylab = expression(italic(S["d"]) (um)), mgp=c(1.1, 0, 0),tck=0.02,
               main = "", xlim = c(-50,300),ylim=c(0,400))

mtext("Sd and slope fit",3,line=0.2,font=2,cex=1.2)

points(k1$ux,k1$sdeva,col=yan[1],pch=pcc[1])
points(k2$ux,k2$sdeva,col=yan[2],pch=pcc[2])
points(k3$ux,k3$sdeva,col=yan[3],pch=pcc[3])
points(k4$ux,k4$sdeva,col=yan[4],pch=pcc[4])

z1<-lm(k1$sdeva~k1$ux)
z2<-lm(k2$sdeva~k2$ux)
z3<-lm(k3$sdeva~k3$ux)
z4<-lm(k4$sdeva~k4$ux)

abline(z1,col=yan[1],lwd=1.5,lty=2)
abline(z2,col=yan[2],lwd=1.5,lty=2)
abline(z3,col=yan[3],lwd=1.5,lty=2)
abline(z4,col=yan[4],lwd=1.5,lty=2)

error.bar(k1$ux,k1$sdeva,k1$sdstd/2,col=yan[1])
error.bar(k2$ux,k2$sdeva,k2$sdstd/2,col=yan[2])
error.bar(k3$ux,k3$sdeva,k3$sdstd/2,col=yan[3])
error.bar(k4$ux,k4$sdeva,k4$sdstd/2,col=yan[4])

leg<-c("600Hz","1KHz","2KHz","2.5KHz")

legend("topright",legend=leg,col=yan,pch=pcc,lwd=1.5,lty=2,inset=.03,bty="n")

# 斜率获取
b1<-z1$coefficients[2]
b2<-z2$coefficients[2]
b3<-z3$coefficients[2]
b4<-z4$coefficients[2]

a1<-z1$coefficients[1]
a2<-z2$coefficients[1]
a3<-z3$coefficients[1]
a4<-z4$coefficients[1]

b<-c(b1,b2,b3,b4)

# 近似的斜率获取

kv2<-b1*0.6

kv3<-b1*0.3

kv4<-b1*0.24

kv<-c(b1,kv2,kv3,kv4)

# 画斜线
par(fig=c(0.08,0.6,0.4,0.98),new=T)

ux<-c(0.6,1,2,2.5)

plot(ux,b, col=0,bty="n",xlab = expression(italic(f["p"]) (KHz)),
          ylab = expression(italic(Slope)), mgp=c(1.1, 0, 0),tck=0.02,
               main = "", xlim = c(0.5,2.5),ylim=c(0,2.2),cex=0.8)

               lines(ux,b,col="red",lwd=1.5,lty=2,pch=pcc[1],type="b")
               lines(ux,kv,col="blue",lwd=1.5,lty=2,pch=pcc[2],type="b")

leg1<-c("fit","fit by fv")

legend("topright",legend=leg1,col=c("red","blue"),pch=c(0,1),lwd=1.5,lty=2,inset=.02,bty="n")


# Conversion from wide to long and back again

# A. From wide to long
# 1. Pivot_longer()
nuke_df %>%
  # Pivot the data to a longer format
  pivot_longer(
    -year,
    # Overwrite the names of the two new columns
    names_to = "country",
    values_to = "n_bombs"
  ) %>%
  # Replace NA values for n_bombs with 0L
  replace_na(list(n_bombs = 0L)) %>%
  # Plot the number of bombs per country over time
  ggplot(aes(x = year, y = n_bombs, color = country)) +
  geom_line()

# 2. Obesity per country
obesity_df %>%
  # Pivot the male and female columns
  pivot_longer(c(male, female),
               names_to = "sex",
               values_to = "pct_obese") %>%
  # Create a scatter plot with pct_obese per country colored by sex
  ggplot(aes(x = pct_obese, color = sex,
             y = forcats::fct_reorder(country, both_sexes))) +
  geom_point() +
  scale_y_discrete(breaks = c("India", "Nauru", "Cuba", "Brazil",
                              "Pakistan", "Gabon", "Italy", "Oman",
                              "China", "United States of America")) +
  labs(x = "% Obese", y = "Country")

# 3. Bond movies by actor
bond_df %>%
  # Pivot the data to long format
  pivot_longer(
    -Bond,
    # Overwrite the names of the two newly created columns
    names_to = "decade",
    values_to = "n_movies",
    # Drop na values
    values_drop_na = TRUE,
    # Transform the decade column data type to integer
    names_transform = list(decade = as.integer)
  ) %>%
  ggplot(aes(x = decade + 5, y = n_movies, fill = Bond))+
  geom_col()

# B. Deriving variables from column headers
# 1. Bird of the year
bird_df %>%
  # Pivot the data to create a 2 column data frame
  pivot_longer(
    starts_with("points_"),
    names_to = "points",
    names_prefix = "points_",
    names_transform = list(points = as.integer),
    values_to = "species",
    values_drop_na = TRUE
  ) %>%
  group_by(species) %>%
  summarize(total_points = sum(points)) %>%
  slice_max(total_points, n = 5)

# 2. Big tech stock prices
stock_df %>%
  # Pivot the data to create 3 new columns: year, week, price
  pivot_longer(
    -company,
    names_to = c("year", "week"),
    values_to = "price",
    names_sep = "_week",
    names_transform = list(
      year = as.integer,
      week = as.integer)
  ) %>%
  # Create a line plot with price per week, color by company
  ggplot(aes(x = week, y = price, color = company)) +
  geom_line() +
  facet_grid(. ~ year)

# C. Deriving variables from complex column headers
# 1. Space dogs
space_dogs_df %>%
  pivot_longer(
    # Add the columns to pivot
    c(name_1, name_2, gender_1, gender_2),
    names_sep = "_",
    # Complete the names_to argument to re-use the first part of the column headers
    names_to = c(".value",  "dog_id"),
    # Make sure NA values are dropped
    values_drop_na = TRUE
  )

# 2. WHO obesity Vs life expectancy
who_df %>%
  # Put each variable in its own column
  pivot_longer(
    -country,
    names_to = c("year", "sex", ".value"),
    names_sep = "_",
    names_transform = list("year" = as.integer)
  ) %>%
  # Create a plot with life expectancy over obesity
  ggplot(aes(x = pct.obese, y = life.exp, color = sex)) +
  geom_point()

# 3. Uncounting observations
dog_df %>%
  # Create one row for each participant and add the id
  uncount(n_participants, .id = "dog_id")

# D. From long to wide
# 1. pivot_wider()
space_dogs_df %>%
  # Pivot the data to a wider format
  pivot_wider(names_from = dog_id, values_from = gender, names_prefix = "gender_") %>%
  # Drop rows with NA values
  drop_na() %>%
  # Create a Boolean column on whether both dogs have the same gender
  mutate(same_gender = gender_1 == gender_2) %>%
  summarize(pct_same_gender = mean(same_gender))

# 2. Planet temperature and distance to sun
planet_df %>%
  # Give each planet variable its own column
  pivot_wider(names_from = "metric", values_from = "value") %>%
  # Plot planet temperature over distance to sun
  ggplot(aes(x = distance_to_sun, y = temperature)) +
  geom_point(aes(size = diameter)) +
  geom_text(aes(label = planet), vjust = -1) +
  labs(x = "Distance to sun (million km)",
       y = "Mean temperature (°C)") +
  theme(legend.position = "none")

# 3. Transposing planet data
# In order to transpose the data the data has to be converted to the long format before converting to wide
planet_df %>%
  # Pivot all columns except metric to long format
  pivot_longer(-metric, names_to = "planet") %>%
  # Put each metric in its own column
  pivot_wider(names_from = metric, values_from = value) %>%
  # Plot the number of moons vs planet diameter
  ggplot(aes(x = diameter, y = number_of_moons)) +
  geom_point(aes(size = diameter)) +
  geom_text(aes(label = planet), vjust = -1) +
  labs(x = "Diameter (km)", y = "Number of moons") +
  theme(legend.position = "none")


# libraries ...

library(pryr);          # mem_used()
library(lmtest);        # lmtest has lrtest
library(MASS);          # polr

library(tractor.base);  # implode

library(stringr);
library(rvest);			# imdb web scraping
library(lubridate);		# POSIXct in imdb cleaning


###############################################################################
# "Infection Rate Models for COVID-19:
#  Model Risk and Public Health News Sentiment Exposure Adjustments"
#
#  Ioannis Chalkiadakis, Kevin Hongxuan Yan, Gareth W. Peters, Pavel V. Shevchenko
#
#  Kevin Hongxuan Yan
#  March 2021
###############################################################################

for (k in 1:7){

D_GM=c("Jan/27","Mar/17","May/05","Jun/25","Jul/17")
D_IT=c("Jan/31","Mar/13","May/09","Jun/29","Jul/17")
D_JP=c("Jan/22","Mar/12","Apr/30","Jun/19","Jul/17")
D_SP=c("Feb/01","Mar/20","May/10","Jun/30","Jul/17")
D_UK=c("Jan/31","Mar/21","May/09","Jun/29","Jul/17")
D_US=c("Jan/22","Mar/12","Apr/30","Jun/19","Jul/17")
D_AU=c("Jan/26","Mar/16","May/04","Jun/24","Jul/17")

Date=c(D_GM,D_IT,D_JP,D_SP,D_UK,D_US,D_AU)

name=c("Germany","Italy","Japan","Spain","U.K.","U.S.","Australia")
abn=c("GM","IT","JP","SP","UK","US","AU")

setwd("./covid19modelrisk/output/M4")

load(paste("M2_",abn[k],".RData",sep=""))

Epars_m <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(6+N):(5+2*N)] , 2 , mean )
Epars_5 <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(6+N):(5+2*N)] , 2 , quantile, probs=0.05 )
Epars_9 <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(6+N):(5+2*N)] , 2 , quantile, probs=0.95 )

y=log(y)
Epars_m=log(Epars_m)
Epars_9=log(Epars_9)
Epars_5=log(Epars_5)

setwd("./covid19modelrisk/output/plot")

pdf(paste("M2_",abn[k],"_log.pdf",sep=""), width = 16.5, height = 8.50)

m=length(y)

newx=c(1:m)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M2 model for ",name[k],sep=""),pch=19,xaxt = 'n')
par(new=TRUE)

polygon(c(rev(newx), newx), c(rev(Epars_9[1:m]), Epars_5[1:m]), col = "grey80", border = NA)

lines(newx,Epars_9[1:m], lty = 'dashed', col = 'red',lwd = 2)
lines(newx, Epars_5[1:m], lty = 'dashed', col = 'red',lwd = 2)
par(new=TRUE)
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M2 model for ",name[k],sep=""),pch=19,xaxt = 'n')
par(new=TRUE)
plot.ts(Epars_m[1:m],col="red",ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M2 model for ",name[k],sep=""),lwd = 2,xaxt = 'n')
legend("bottomright", legend=c("Observed data", "Fitted data"), col=c("black", "red"), lty=c(1,1), lwd = 3,cex=2)
axis(1, at=c(0,50,100,150,180), labels=c(Date[(k-1)*5+1],Date[(k-1)*5+2],Date[(k-1)*5+3],Date[(k-1)*5+4],Date[(k-1)*5+5]))
dev.off()

setwd("./covid19modelrisk/output/M2")

load(paste("M4_",abn[k],".RData",sep=""))

Epars_m <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(7+N):(6+2*N)] , 2 , mean )
Epars_5 <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(7+N):(6+2*N)] , 2 , quantile, probs=0.05 )
Epars_9 <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(7+N):(6+2*N)] , 2 , quantile, probs=0.95 )

y=log(y)
Epars_m=log(Epars_m)
Epars_9=log(Epars_9)
Epars_5=log(Epars_5)

setwd("./covid19modelrisk/output/plot")

pdf(paste("M4_",abn[k],"_log.pdf",sep=""), width = 16.5, height = 8.50)

m=length(y)

newx=c(1:m)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M4 model for ",name[k],sep=""),pch=19,xaxt = 'n')
par(new=TRUE)

polygon(c(rev(newx), newx), c(rev(Epars_9[1:m]), Epars_5[1:m]), col = "grey80", border = NA)

lines(newx,Epars_9[1:m], lty = 'dashed', col = 'red',lwd = 2)
lines(newx, Epars_5[1:m], lty = 'dashed', col = 'red',lwd = 2)
par(new=TRUE)
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M4 model for ",name[k],sep=""),pch=19,xaxt = 'n')
par(new=TRUE)
plot.ts(Epars_m[1:m],col="red",ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M4 model for ",name[k],sep=""),lwd = 2,xaxt = 'n')
legend("bottomright", legend=c("Observed data", "Fitted data"), col=c("black", "red"), lty=c(1,1), lwd = 3,cex=2)
axis(1, at=c(0,50,100,150,180), labels=c(Date[(k-1)*5+1],Date[(k-1)*5+2],Date[(k-1)*5+3],Date[(k-1)*5+4],Date[(k-1)*5+5]))
dev.off()

setwd("./covid19modelrisk/output/M7")

load(paste("M7_",abn[k],".RData",sep=""))

Epars_m <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(7+N):(6+2*N)] , 2 , mean )
Epars_5 <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(7+N):(6+2*N)] , 2 , quantile, probs=0.05 )
Epars_9 <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(7+N):(6+2*N)] , 2 , quantile, probs=0.95 )

y=log(y)
Epars_m=log(Epars_m)
Epars_9=log(Epars_9)
Epars_5=log(Epars_5)

setwd("./covid19modelrisk/output/plot")

pdf(paste("M7_",abn[k],"_log.pdf",sep=""), width = 16.5, height = 8.50)

m=length(y)

newx=c(1:m)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M7 model for ",name[k],sep=""),pch=19,xaxt = 'n')
par(new=TRUE)

polygon(c(rev(newx), newx), c(rev(Epars_9[1:m]), Epars_5[1:m]), col = "grey80", border = NA)

lines(newx,Epars_9[1:m], lty = 'dashed', col = 'red',lwd = 2)
lines(newx, Epars_5[1:m], lty = 'dashed', col = 'red',lwd = 2)
par(new=TRUE)
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M7 model for ",name[k],sep=""),pch=19,xaxt = 'n')
par(new=TRUE)
plot.ts(Epars_m[1:m],col="red",ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M7 model for ",name[k],sep=""),lwd = 2,xaxt = 'n')
legend("bottomright", legend=c("Observed data", "Fitted data"), col=c("black", "red"), lty=c(1,1), lwd = 3,cex=2)
axis(1, at=c(0,50,100,150,180), labels=c(Date[(k-1)*5+1],Date[(k-1)*5+2],Date[(k-1)*5+3],Date[(k-1)*5+4],Date[(k-1)*5+5]))
dev.off()

setwd("./covid19modelrisk/output/M12")

load(paste("M12_",abn[k],".RData",sep=""))

Epars_m <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(7+N):(6+2*N)] , 2 , mean )
Epars_5 <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(7+N):(6+2*N)] , 2 , quantile, probs=0.05 )
Epars_9 <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(7+N):(6+2*N)] , 2 , quantile, probs=0.95 )

y=log(y)
Epars_m=log(Epars_m)
Epars_9=log(Epars_9)
Epars_5=log(Epars_5)

setwd("./covid19modelrisk/output/plot")

pdf(paste("M12_",abn[k],"_log.pdf",sep=""), width = 16.5, height = 8.50)

m=length(y)

newx=c(1:m)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M12 model for ",name[k],sep=""),pch=19,xaxt = 'n')
par(new=TRUE)

polygon(c(rev(newx), newx), c(rev(Epars_9[1:m]), Epars_5[1:m]), col = "grey80", border = NA)

lines(newx,Epars_9[1:m], lty = 'dashed', col = 'red',lwd = 2)
lines(newx, Epars_5[1:m], lty = 'dashed', col = 'red',lwd = 2)
par(new=TRUE)
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M12 model for ",name[k],sep=""),pch=19,xaxt = 'n')
par(new=TRUE)
plot.ts(Epars_m[1:m],col="red",ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M12 model for ",name[k],sep=""),lwd = 2,xaxt = 'n')
legend("bottomright", legend=c("Observed data", "Fitted data"), col=c("black", "red"), lty=c(1,1), lwd = 3,cex=2)
axis(1, at=c(0,50,100,150,180), labels=c(Date[(k-1)*5+1],Date[(k-1)*5+2],Date[(k-1)*5+3],Date[(k-1)*5+4],Date[(k-1)*5+5]))
dev.off()

D_GM=c("Jan/27","May/05","Aug/13","Nov/21","Jan/10")
D_IT=c("Jan/31","May/09","Aug/17","Nov/25","Jan/14")
D_JP=c("Jan/22","Apr/30","Aug/08","Nov/16","Jan/5")
D_SP=c("Feb/01","May/10","Aug/18","Nov/26","Jan/15")
D_UK=c("Jan/31","May/09","Aug/17","Nov/25","Jan/14")
D_US=c("Jan/22","Apr/30","Aug/08","Nov/16","Jan/5")
D_AU=c("Jan/26","May/04","Aug/12","Nov/20","Jan/9")

Date=c(D_GM,D_IT,D_JP,D_SP,D_UK,D_US,D_AU)

name=c("Germany","Italy","Japan","Spain","U.K.","U.S.","Australia")
abn=c("GM","IT","JP","SP","UK","US","AU")

setwd("./covid19modelrisk/output/M2_extra")

load(paste("M2_",abn[k],".RData",sep=""))

Epars_m <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(6+N):(5+2*N)] , 2 , mean )
Epars_5 <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(6+N):(5+2*N)] , 2 , quantile, probs=0.05 )
Epars_9 <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(6+N):(5+2*N)] , 2 , quantile, probs=0.95 )

y=log(y)
Epars_m=log(Epars_m)
Epars_9=log(Epars_9)
Epars_5=log(Epars_5)

setwd("./covid19modelrisk/output/plot")

pdf(paste("M2_",abn[k],"_log_LONG.pdf",sep=""), width = 16.5, height = 8.50)

m=length(y)

newx=c(1:m)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M2 model for ",name[k],sep=""),pch=19,xaxt = 'n')
par(new=TRUE)

polygon(c(rev(newx), newx), c(rev(Epars_9[1:m]), Epars_5[1:m]), col = "grey80", border = NA)

lines(newx,Epars_9[1:m], lty = 'dashed', col = 'red',lwd = 2)
lines(newx, Epars_5[1:m], lty = 'dashed', col = 'red',lwd = 2)
par(new=TRUE)
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M2 model for ",name[k],sep=""),pch=19,xaxt = 'n')
par(new=TRUE)
plot.ts(Epars_m[1:m],col="red",ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M2 model for ",name[k],sep=""),lwd = 2,xaxt = 'n')
legend("bottomright", legend=c("Observed data", "Fitted data"), col=c("black", "red"), lty=c(1,1), lwd = 3,cex=2)
axis(1, at=c(0,100,200,300,350), labels=c(Date[(k-1)*5+1],Date[(k-1)*5+2],Date[(k-1)*5+3],Date[(k-1)*5+4],Date[(k-1)*5+5]))

dev.off()

setwd("./covid19modelrisk/output/M7_extra")

load(paste("M7_",abn[k],".RData",sep=""))

Epars_m <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(7+N):(6+2*N)] , 2 , mean )
Epars_5 <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(7+N):(6+2*N)] , 2 , quantile, probs=0.05 )
Epars_9 <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(7+N):(6+2*N)] , 2 , quantile, probs=0.95 )

y=log(y)
Epars_m=log(Epars_m)
Epars_9=log(Epars_9)
Epars_5=log(Epars_5)

setwd("./covid19modelrisk/output/plot")

pdf(paste("M7_",abn[k],"_log_LONG.pdf",sep=""), width = 16.5, height = 8.50)

m=length(y)

newx=c(1:m)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M7 model for ",name[k],sep=""),pch=19,xaxt = 'n')
par(new=TRUE)

polygon(c(rev(newx), newx), c(rev(Epars_9[1:m]), Epars_5[1:m]), col = "grey80", border = NA)

lines(newx,Epars_9[1:m], lty = 'dashed', col = 'red',lwd = 2)
lines(newx, Epars_5[1:m], lty = 'dashed', col = 'red',lwd = 2)
par(new=TRUE)
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M7 model for ",name[k],sep=""),pch=19,xaxt = 'n')
par(new=TRUE)
plot.ts(Epars_m[1:m],col="red",ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M7 model for ",name[k],sep=""),lwd = 2,xaxt = 'n')
legend("bottomright", legend=c("Observed data", "Fitted data"), col=c("black", "red"), lty=c(1,1), lwd = 3,cex=2)
axis(1, at=c(0,100,200,300,350), labels=c(Date[(k-1)*5+1],Date[(k-1)*5+2],Date[(k-1)*5+3],Date[(k-1)*5+4],Date[(k-1)*5+5]))

dev.off()

setwd("./covid19modelrisk/output/M12_extra")

load(paste("M12_",abn[k],".RData",sep=""))

Epars_m <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(7+N):(6+2*N)] , 2 , mean )
Epars_5 <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(7+N):(6+2*N)] , 2 , quantile, probs=0.05 )
Epars_9 <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(7+N):(6+2*N)] , 2 , quantile, probs=0.95 )

y=log(y)
Epars_m=log(Epars_m)
Epars_9=log(Epars_9)
Epars_5=log(Epars_5)

setwd("./covid19modelrisk/output/plot")

pdf(paste("M12_",abn[k],"_log_LONG.pdf",sep=""), width = 16.5, height = 8.50)

m=length(y)

newx=c(1:m)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M12 model for ",name[k],sep=""),pch=19,xaxt = 'n')
par(new=TRUE)

polygon(c(rev(newx), newx), c(rev(Epars_9[1:m]), Epars_5[1:m]), col = "grey80", border = NA)

lines(newx,Epars_9[1:m], lty = 'dashed', col = 'red',lwd = 2)
lines(newx, Epars_5[1:m], lty = 'dashed', col = 'red',lwd = 2)
par(new=TRUE)
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M12 model for ",name[k],sep=""),pch=19,xaxt = 'n')
par(new=TRUE)
plot.ts(Epars_m[1:m],col="red",ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M12 model for ",name[k],sep=""),lwd = 2,xaxt = 'n')
legend("bottomright", legend=c("Observed data", "Fitted data"), col=c("black", "red"), lty=c(1,1), lwd = 3,cex=2)
axis(1, at=c(0,100,200,300,350), labels=c(Date[(k-1)*5+1],Date[(k-1)*5+2],Date[(k-1)*5+3],Date[(k-1)*5+4],Date[(k-1)*5+5]))

dev.off()

}


# Import necessary packages
library(tibble)
library(dplyr)
library(forcats)
library(ggplot2)

# Generate the data
df <- tibble(
  Group = c(rep("X", 4), rep("Y", 6)),
  Subgroup = c(rep("a", 3), "z", rep("a", 3), rep("z", 3)),
  Value = sample(20, 10, replace = TRUE)
)

# Grouped table
df %>%
  # Concatenate
  bind_rows(
    df %>% mutate(Subgroup = "Total"),
    df %>% mutate(across(c(Group, Subgroup), ~ "Total"))
  ) %>%
  # Aggregate
  group_by(
    Group,
    Subgroup
  ) %>%
  summarise(
    Mean = mean(Value)
  ) %>%
  ungroup() %>%
  # Reorder factor levels
  mutate(
    Group = Group %>% as.factor() %>% fct_relevel("Total", after = Inf),
    Subgroup = Subgroup %>% as.factor() %>% fct_relevel("Total", after = Inf)
  ) %>%
  # Arrange
  arrange(
    Group,
    Subgroup
  )

# Dataviz example

## Group data
df <- mtcars %>%
  mutate(
    cyl = cyl %>% as.character()
  ) %>%
  bind_rows(
    mtcars %>% mutate(cyl = 'Total')
  ) %>%
  mutate(
    cyl = cyl %>% as.factor() %>% fct_relevel("Total", after = Inf)
  ) %>%
  group_by(
    cyl
  ) %>%
  summarize(
    mean_mpg = mean(mpg)
  )

# Visualize
ggplot(data = df) +
  aes(x = cyl, y = mean_mpg) +
  geom_col(color = "cornflowerblue", fill = "cornflowerblue") +
  xlab("Number of cylinders") +
  scale_y_continuous(name = "Miles / gallon", breaks = seq(0, 30, 5)) +
  ggtitle("Average miles/gallon by number of cylinders") +
  theme_minimal() +
  theme(
    plot.title = element_text(hjust = 0.5),
    text = element_text(size=25)
  )


# Functions for Multifractal analysis

## p-model

# Calculates pmodel using the C++ compiled program
# the output is a file in "sed" format
#
# I use the following to have only one parameter:
# $p2=p3=p4=(1-p1)/3$
#
# fname: output file name
# p1: p1 parameter for pmodel
# iter: (default=9) gives the image size $lado = 2^iter$
# rnd: how I assign p at each step S->random with reposition
#

calc_pmodel1 <- function(fname,p1,iter=9,rnd="S")
  {
  if(p1==0 | iter<2) stop("p1 == 0 or iter<2")
  if(file.exists(fname))
    file.remove(fname)
  p2 <- p3 <- p4 <- (1-p1)/3
  syst.txt <- paste("./pmodel", p1,p2,p3,p4,iter,fname,rnd)
  system(syst.txt)
  }

# Plot a sed file from pmodel using lattice
#
# fname: sed file with pmodel output
# p1: parameter for title
#
plot_pmodel1 <- function(fname,p1)
  {
  require(lattice)
  per <- read.table(fname, skip=2,header=F)
  per <-data.matrix(per)*(2^(2*iter))
  col.l <- colorRampPalette(c('white', 'green', 'purple', 'yellow', 'brown'))(64)
  levelplot(per, scales = list(draw = FALSE),xlab =NULL, ylab = NULL,col.regions=col.l,
            useRaster=T,
            main=list( paste("p1=",p1),cex=1))
  }

# Plot a sed file
#
# fname: file name
# gname: graph title
# dX: range in columns to plot
# col: vector of colors to make the color palette
# shf: shift in the vector of colors
#
plot_image <- function(fname,gname,dX=0,col=0,shf=0)
  {
  require(lattice)
  require(RColorBrewer)
  per <-data.matrix(read.table(fname, skip=2,header=F))
  if(length(dX)>1) per <- per[,dX]
  mp = max(per)
  if(mp<50) {
    mp = 50
    seqat = seq( min(per),max(per),(max(per)-min(per))/50)
  }
  else
  {
    seqat = seq( min(per),mp,5)
  }
  if(length(col)==1) col.l <- colorRampPalette(c('white', 'green', 'purple', 'yellow', 'brown'))(mp)
  else col.l <- colorRampPalette(col)(mp)
  if( shf>0) col.l = col.l[shf:mp]
  levelplot(per, scales = list(draw = FALSE),xlab =NULL, ylab = NULL,col.regions=col.l,
            useRaster=T,at=seqat,
            main=list( gname,cex=1))
  }

# Read a sed file in a matrix
#
#
read_sed <- function(fname)
{
  per <-data.matrix(read.table(fname, skip=2,header=F))
}

# Calculates the multifractal spectrum and
# put the result in a frame
#
calcDq_mfSBA <- function(fname,recalc=FALSE)
  {
  sname <- paste0("s.", fname)
  if((!file.exists(sname)) | recalc)
    {
    syst.txt <- paste("./mfSBA ",fname, "q.sed 2 512 20 S")
    system(syst.txt)
    }
  pp <- read.table(sname, header=T)

  pp$Dq  <- with(pp,ifelse(q==1,alfa,Tau/(q-1)))
  pp$SD.Dq  <- with(pp,ifelse(q==1,SD.alfa,abs(SD.Tau/(q-1))))
  pp$R.Dq <- with(pp,ifelse(q==1,R.alfa,R.Tau))
  return(pp[,c("q","Dq","SD.Dq","R.Dq")])
  }

# Calc mfSBA
# draw histogram
# add to a dataframe dq with a new variable site = siten
#
addDqRHist <- function(fname,dq=0,siten="")
{
  # Extract site label
  if( nchar(siten)==0 ){
    siten <- strsplit(fname,".sed")[[1]][1]
  }

  # Make multifractal analysis

  dqnew <- calcDq_mfSBA(fname)
  dqnew$Site <- siten

  require(ggplot2)

  #print(ggplot(dqnew, aes(x=R.Dq)) + geom_histogram() + ggtitle(siten))
  hist(dqnew$R.Dq)
  if(is.data.frame(dq))
    return(rbind(dq,dqnew))
  else
    return(dqnew)
}

# Do repeated simulations of pmodel and store the results in a dataframe.
#
repeat_pmodel <- function(p1,fname,reps) {

  for(i in 1:reps)
  {
    calc_pmodel1(fname,p1)
    #plot_pmodel1(fname,p1)
    s_Dq <- calcDq_mfSBA(fname,T) # recalc = TRUE
    s_Dq$p1 <- p1
    s_Dq <-na.omit(s_Dq)
    a_Dq <-if(!exists("a_Dq")) s_Dq else rbind(a_Dq,s_Dq)
    }
  #plot_pmodel1(fname,p1)
  return(a_Dq)
}

# Auxiliar function for boot
#
mediaDq <- function(dq,i) mean(dq[i])

# Calculates CI using boot
#
#             sp: frame to put Dq|q
#             the following are to identify the output
#             p1: the value of p1 used in p-model
#             type: the type of the run
calcDq_bootCI <- function(sp,p1,type)
  {
  require(boot)
  require(plyr)
  sp <- na.omit(sp)
  testBoot <- with(sp,by(Dq,q,boot, mediaDq, R=1000))
  # boot pg 331
  bt <-boot.ci(testBoot[[1]])
  testCI <-  sapply(testBoot, boot.ci)
  compCI1<-data.frame(matrix(unlist(testCI),ncol=21,byrow=T)[,c(2,15,16)])
  names(compCI1)=c("Dq","LowCI","HighCI")
  compCI1$q<-as.numeric(names(testBoot))
  compCI1$p1 <-p1
  compCI1$Type <-type
  compCI1$SD.Dq <-ldply(testBoot, function(e) sd(e$t))$V1
  return(compCI1)
  }

# Function to graph multifractal spectra with CI
#
# El error dinnames es que no todas las variables son numéricas
# Usa Type como variable de grupo y LowCI,HighCI para el CI
#
plot_DqCI <- function(DqCI, tit="Type")
  {
  require(lattice)
  require(Hmisc)
  with(DqCI,
    xYplot(Cbind(Dq,LowCI,HighCI) ~ q, data=DqCI, nx=FALSE, groups=Type, type="l",
           scales=list(tck=-1),
           cap=.01,
           ylim=c(min(DqCI$LowCI)-.01,max(DqCI$HighCI)+.01),
    	     panel=function(...){
  		     panel.abline(h=2, col="grey", lty=2)
  		     panel.xYplot(...)},
  		     ylab=expression(italic(D[q])),
  		     xlab=expression(italic(q)),
           label.curves=F,
           auto.key=list(x=.65,y=.9,title=tit,cex.title=.9, lines=T,points=F,cex=.7),
           )
       )
  }

# Calculates theoretic Dq from pmodel
#
calcDqTeor <- function(q,p1) {
  if( q==1)
    q <- q+1e-10
  p2 <- p3 <- p4 <- (1-p1)/3
  f1 <- p1/(p1+p2+p3+p4)
  f2 <- p2/(p1+p2+p3+p4)
  f3 <- p3/(p1+p2+p3+p4)
  f4 <- p4/(p1+p2+p3+p4)
  dq <- log2(f1^q+f2^q+f3^q+f4^q)/(1-q)
  return(dq)
  }

# Function for CI from SD
#
calcCI <- function(dat,n,p) qt(1-p/2,n-1)*sqrt(dat*dat/n)

# Function to plot Dq fit from t* files generated by mfSBA
# Beware! Is fixed for q interval -5 to 5
#
plotDqFit <- function(fname,wtitle="")
{

  zq <- read.table(fname, sep="\t", skip=1,
                   col.names=c("BoxSize","logBox","Xminus5","Xminus4.5","Xminus4","Xminus3.5","Xminus3","Xminus2.5","Xminus2","Xminus1.5","Xminus1","Xminus0.5","X0","X0.5","X1","X1.5","X2","X2.5","X3","X3.5","X4","X4.5","X5")
  )
  #cna=seq(-5,5,by=0.5)
  cna =c(-5,-4.5,-4,-3.5,-3,-2.5,-2,-1.5,-1,-0.5,0,0.5,1,1.5,2,2.5,3,3.5,4,4.5,5)
  zq0=reshape(zq, timevar="q",times=cna,v.names=c("logTr"),
              varying=list(c("Xminus5","Xminus4.5","Xminus4","Xminus3.5","Xminus3","Xminus2.5","Xminus2","Xminus1.5","Xminus1","Xminus0.5","X0","X0.5","X1","X1.5","X2","X2.5","X3","X3.5","X4","X4.5","X5")),
              direction="long")

  library(lattice)
  zq1 <- subset(zq0, q==1 | q==2 | q==3 | q==4 | q==5 | q==0 | q==-1 | q==-2 | q==-3 | q==-4 | q==-5 )

#  oname <- paste("lsaravia_figS_W",sem,"_",wnro,".tif",sep="")

#  tiff(oname, width=4.86,height=4.86,units="in",res=600,compression=c("lzw"))
  #devAskNewPage(TRUE)

  trellis.par.set(superpose.symbol=list(pch=c(0,1,2,3,4,5,6,8,15,16,17)))
  trellis.par.set(superpose.symbol=list(cex=c(rep(0.6,11))))
  trellis.par.set(superpose.line=list(lty=3))

  #show.settings()

  print(xyplot(logTr~logBox , data =zq1, groups=q, type=c("r","p"), scales=list(tck=-1),
               main=list(wtitle,cex=0.9),
               auto.key=list(space = "right",title=expression(italic("q")),cex.title=.7, points=TRUE,cex=.7),
               ylab=expression(italic(paste("log ",  Z[q](epsilon) ))) , xlab=expression(italic(paste("log ",epsilon)))
  ))
#  dev.off()
}

# Calculates Dq from a data.frame read from the output of neutral model
# auxiliar function for the next one
#
calcDq_frame <- function(pp)
  {
  pp$Dq  <- with(pp,ifelse(q==1,alfa,Tau/(q-1)))
  pp$SD.Dq  <- with(pp,ifelse(q==1,SD.alfa,abs(SD.Tau/(q-1))))
  pp$R.Dq <- with(pp,ifelse(q==1,R.alfa,R.Tau))
  return(pp[,c(1:5,15:17)])
  }

# Reads the output of multifractal spectra of neutral model
# an calculates Dq
#
readNeutral_calcDq <-function(fname)
{
  md1 <- read.table(fname,header=F,skip=1)
  md1 <- md1[,c(2:4, 6:16)]
  names(md1)<-c("MortalityRate","DispersalDistance","ColonizationRate","Time","q","Tau","alfa","f(alfa)","R.Tau","R.alfa","R.f","SD.Tau","SD.alfa","SD.f")

  md1 <-calcDq_frame(md1)
}

# Save a matrix as a sed file with type BI (floating point)
#
save_matrix_as_sed <- function(mat,fname)
{
  header <- paste(nrow(mat),ncol(mat),"BI")
  write.table(header,file=fname,row.names=F,col.names=F,quote=F)
  write.table(mat,file=fname,row.names=F,col.names=F,quote=F,append=T)
}


library(lme4)
library(fields)
library(stringr)
source('~esswein/lib/R/runinfo.R')
source('~esswein/lib/R/strssep.R')

if (!exists('do.pdf')) do.pdf = F
if (!exists('do.txt')) do.txt = F

ri = runinfo()

file.pdf = sub('Regress.rds$','LOOxvalid.pdf',file.regress)
file.txt = sub('pdf$','txt',file.pdf)
file.rds = sub('pdf$','rds',file.pdf)

if (do.txt) {
  sink(file.txt)
  cat('cross validation for',file.regress,'\n\n')
  cat('written_by',ri$prog,'\n\n')
}
base.dat = readRDS(file.regress)

site.list = dimnames(base.dat$site.data)[[3]]
n.site = length(site.list)
DOYlist = sort(unique(base.dat$site.df$DOY))
n.DOY = length(DOYlist)

all.fit = list()
DOYranef.site = matrix(NA,n.site,n.DOY)
DOYsumcoef = rep.int(0,n.DOY)
DOYcoefcount = rep.int(0,n.DOY)
DOYmeancoef = rep.int(NA,n.DOY)
fixint.site = rep.int(NA,n.site)
fixcoef.site = rep.int(NA,n.site)
mse.loo = rep.int(NA,n.site)
mse.pred = rep.int(NA,n.site)

dat = base.dat$site.df
row.names(dat) = str_c('A',1:nrow(dat))

if (do.pdf) pdf(file.pdf,title=paste('written_by',ri$prog))

ifit = 0
for (i.site in 1:n.site) {
  site = site.list[i.site]
  cat(site,'\n')
  w.site = which(dat$name == site)
  if (length(w.site) == 0) {
    cat(site,'not present\n')
    next
  }
  if (length(which(!is.na(dat$PM2.5[w.site]))) == 0) {
    cat('no observed PM2.5 for',site,'\n')
    next
  }
  if (do.txt) cat('site',site,'\n\n')
  dat.loo = dat[-w.site,]
  fit.loo = lmer(base.dat$model,data=dat.loo)
  if (do.txt) print(summary(fit.loo))
  all.fit[[str_c('omit_',site)]] = fit.loo
  ranef.int = ranef(fit.loo)$DOY[,1]
  ranef.DOY = as.integer(as.character(rownames(ranef(fit.loo)$DOY)))
  fixef.int = fixef(fit.loo)[1]
  fixef.coef = fixef(fit.loo)[2]
  mse.loo[i.site] = mean(residuals(fit.loo)^2,na.rm=T)
  if (do.txt) cat('\nMSE for fit',mse.loo[i.site],'\n')
  ## This causes an error:
# fit.loo = lmer(base.dat$model,data=dat.loo,na.action=na.exclude)
  # Indices of DOY for this fit, in the entire DOY list:
  i.DOY = match(ranef.DOY,DOYlist)
  DOYsumcoef[i.DOY] = DOYsumcoef[i.DOY] + ranef.int
  DOYcoefcount[i.DOY] = DOYcoefcount[i.DOY] + 1
  DOYranef.site[i.site,i.DOY] = ranef.int
  fixint.site[i.site] = fixef.int
  fixcoef.site[i.site] = fixef.coef

  predicted = predict(fit.loo,dat[w.site,],allow.new.levels=T)
  mse.pred[i.site] = mean((predicted-dat$PM2.5[w.site])^2,na.rm=T)
  if (do.txt) cat('\nMSE for predicted',mse.pred[i.site],'\n')

  # Attempt to calculate predicted without "predict()":
  if (model == 'Ac') pred.test = ranef.int[match(dat$DOY[w.site],ranef.DOY)] + fixef.int + fixef.coef * dat$AOT[w.site]/dat$CWV[w.site]
  if (model == 'Bc') pred.test = ranef.int[match(dat$DOY[w.site],ranef.DOY)] * dat$AOT[w.site]/dat$CWV[w.site] + fixef.int + fixef.coef * dat$AOT[w.site]/dat$CWV[w.site]
# cat('predictions diffs',mean(abs(predicted-pred.test),na.rm=T),'\n')
# cat('predictions mean',mean(abs(predicted),na.rm=T),'\n')

  title = c(str_c(site,' LOO xvalid'),paste(base.dat$daterange,collapse=' '),as.character(deparse(formula(base.dat$model))))
  plot(dat[w.site,'PM2.5'],predicted,xlim=c(0,80),ylim=c(0,80),main=title,xlab='Obs PM2.5',ylab='Pred PM2.5')
  ifit = ifit + 1
  cat('\n\n')
}

  fit = lmer(base.dat$model,data=dat)
  all.fit[['all_sites']] = fit
  plot(fitted(fit)+residuals(fit),fitted(fit),xlab='Obs',ylab='Fitted',main='Fit for all sites')
  cat('\n\nFit with all data\n\n')
  if (do.txt) {
    print(summary(fit))
    cat('\nMSE for fit',mean(residuals(fit)^2,na.rm=T),'\n')
  }

  DOYmeancoef[DOYcoefcount > 0] = DOYsumcoef[DOYcoefcount > 0] / DOYcoefcount[DOYcoefcount > 0]
  fixintmean = mean(fixint.site,na.rm=T)
  fixcoefmean = mean(fixcoef.site,na.rm=T)
###
## w.cc = which(complete.cases(dat[,names(model.frame(base.dat$fit))]))
####
  w.cc = which(complete.cases(dat[,strssep('PM2.5 AOT CWV DOY')]))
  if (model.id == 'A') {
    pred.all = DOYmeancoef[match(dat$DOY[w.cc],DOYlist)] + fixintmean + fixcoefmean * dat$AOT[w.cc]/dat$CWV[w.cc]
    have.predict = T
  } else if (model.id == 'B') {
    pred.all = DOYmeancoef[match(dat$DOY[w.cc],DOYlist)] *dat$AOT[w.cc]/dat$CWV[w.cc] + fixintmean + fixcoefmean * dat$AOT[w.cc]/dat$CWV[w.cc]
    have.predict = T
  } else {
    cat('Prediction formula not available for this model\n')
    have.predict = F
  }

  if (have.predict) {
    if (do.txt) cat('\nMSE for predicted using averaged coefficients',mean((pred.all-dat$PM2.5[w.cc])^2,na.rm=T),'\n')

    plot(pred.all,fitted(fit),xlab='predicted using mean coefficients',ylab='fitted using all sites',main='compare PM2.5 predictions')
    plot(fitted(fit)-pred.all,xlab='',ylab='fitted - predicted',main='compare PM2.5 predictions')
  }

  plot(fixint.site,main='fixed intercept by site',xlab='site')
  plot(fixcoef.site,main='fixed coefficient by site',xlab='site')
  image.plot(DOYranef.site,xlab='site',ylab='DOY',main='DOY ranef')

if (do.txt) {
  sink()
  cat(file.txt,'\n')
  saveRDS(all.fit,file.rds)
}

if (do.pdf) {
  dev.off()
  cat(file.pdf,'\n')
}


library()
### generate z-scores for NHMMfdr

z <- qnorm(1-DMPs$P.Value)

### fit NHMMfdr

fitHMM <- fdr.nhmm(z,alttype="mixnormal",L=1)

# Z should be a matrix of covariates (try CpG island status)
# Also try
# dist is a vector indicating distances?
#fitNHMM <- fdr.nhmm(z,Z = annEPICSub$Relation_to_Island, alttype="mixnormal",L=2)
# ix <- annEPICSub$chr == "chr1"
fitNHMM <- fdr.nhmm(x = z[ix], dist = annEPICSub[ix, ]$pos)

#LIS.adjust <- LIS.adjust(fitNHMM$LIS,fdr=0.05,adjust=TRUE)
#DMPs <- cbind(DMPs,LIS.adjust$States,LIS.adjust$aLIS)
#length(which(LIS.adjust$States==1))

#fwrite(DMPs,file="adrcSmoking.DMPs.csv",quote=F,row.names=T)
#save(c(DMPs, fit2),file="adrcSmoking.DMPs.RData")

### repeat analysis with other variables of interest


############################################################################################################################
#### This Scipt describes an example of running a dataset to impute values
#### based on KNN-CR, KNN-TN and KNN-EU
############################################################################################################################

source("Trunc_KNN/Imput_funcs.r")
source("Trunc_KNN/Simulation.r")

### Load libraries as some functions are dependent on them

library(MASS)
library(mvtnorm)
library(Matrix)
library(magrittr)

###########################################################################
##### Here we Simulate a dataset of size 50 Samples by 400 Metabolites
##### We will have a Complete Dataset and a Dataset with Missing Values
##### For this example we generate a Dataset with 15% total Missing where
##### 10% of the Data is missing below the Threshold and 5% missing above
##### the threshold. We also discard if there is missing greater than 75%.
############################################################################
set.seed(505)
CorrelationMatrix0.7 <- CorrMatrixNegFixed(20, 20, 0.7, 0.2)
DataSimul <- SimulatedData(50, 400, as.matrix(nearPD(CorrelationMatrix0.7)[[1]]), low = -5, high =5)

## Simulate 15% overall missing, 10% due to below LOD (MNAR), 5% MAR
## Only retain metabolites with <75% MVs
Missingness <- MissingData(DataSimul, 15, 5, 0.75)

CompleteData <- Missingness[[2]]
MissData <- Missingness[[1]]
dim(MissData) ## 50x390; After Screening we have 50 Samples and 390 Metabolites

sum(is.na(MissData)/length(MissData))  ## 13.5%, below 15% due to screening

LOD <- quantile(DataSimul, probs = 0.1)

##################################################################################
### We now do the different imputations and we provide the type of imputation and
### k neighbors
##################################################################################

(kNN_Corr_Imp <- imputeKNN(t(MissData), k=10 , distance = "correlation"))
(kNN_Euc_Imp <- KNNEuc(t(MissData), k=10))
(kNN_Trunc_Imp <- imputeKNN(t(MissData), k=10 , distance = "truncation", perc= 0.75))

###################################################################################
### We compute the RMSE since we have the CompleteData, MissingData and ImputedData
####################################################################################

RMSError <- ErrorsComputation(trunc=kNN_Trunc_Imp, corr=kNN_Corr_Imp, euc=kNN_Euc_Imp,
                              miss=MissData, complete = CompleteData)

names(RMSError) <- c("KNN-TN", "KNN-CR", "KNN-EU")
RMSError
##   KNN-TN   KNN-CR   KNN-EU
## 1.161180 1.345218 1.606502

######################################################################################
### We look at the Distribution of Metabolites based on the Imputation Method
######################################################################################

## This plots the first 20 Metabolites of the Dataset and overlays the imputed values
## from the different methods in different colors
## Reproduces Figure 6 in the manuscript

dim(MissData)
sum(is.na(MissData[,1:20]))  ## 190

png("Figure6.png", width = 7, height = 7, units = 'in', res = 600)

col.black <- rgb(0,0,0,alpha=20,maxColorValue=255)
col.black2 <- rgb(0,0,0,alpha=255,maxColorValue=255)

col.blue  <- rgb(0,0,255,alpha=200,maxColorValue=255)
col.red   <- rgb(255,0,0,alpha=200,maxColorValue=255)
col.green <- rgb(0,255,0,alpha=200,maxColorValue=255)

idx.na <- which(is.na(MissData[,1:20]))

plot(rep(1:20, each = 50)[-idx.na], CompleteData[,1:20][-idx.na],
         xlab = "Metabolite", ylab = "Intensity Values", xlim=c(0, 20.5),
         pch = 1, ylim = c(-8,8), col = col.black, cex = 0.9) ##, xaxt='n')

## Just use 'points' to add to a plot rather than the 'plot' command
points(rep(1:20, each = 50)[idx.na], CompleteData[,1:20][idx.na],
       pch = 8, col = col.black2, cex = 0.9)

## Need to make these colors more transparent so we can see all of them
## Shift these slightly to the right when plotting ...

points(rep(1:20, each = 50)[idx.na]+0.23,  t(kNN_Trunc_Imp[1:20,])[idx.na],
       pch=17,  ylim = c(-8,8), col = col.blue, cex = 0.9)  ## Trun
points(rep(1:20, each = 50)[idx.na]+0.46,  t(kNN_Corr_Imp[1:20,])[idx.na],
       pch=15,  ylim = c(-8,8),col = col.red, cex = 0.9)   ## Corr
points(rep(1:20, each = 50)[idx.na]+0.7,  t(kNN_Euc_Imp[1:20,])[idx.na],
       pch=18,  ylim = c(-8,8),col = col.green, cex = 0.9)  ## EUC

legend("topleft", c("Original-Observed", "Orginal-Missing", "KNN-TN", "KNN-CR", "KNN-EU"),
       pch = c(1, 8, 17, 15, 18), col = c(1, 1, 4, 2, 3),  bty = "n",
       text.col = c(1, 1, 4, 2, 3), pt.cex = 1)

## Color region below LOD light red
col.red2   <- rgb(255,0,0,alpha=25,maxColorValue=255)
lims <- par("usr")
polygon(x = c(lims[1], lims[2], lims[2], lims[1]), y = c(LOD, LOD, lims[3], lims[3]), col = col.red2,
        border = NA)

dev.off()


# Load the data from the csv file
dataDirectory <- "D:/DropBox/Dropbox/@Alex_Tutoriaux/"
data <- read.csv(paste(dataDirectory, 'regression.csv', sep=""), header = TRUE)

# Plot the data
plot(data, pch=16)

# Create a linear regression model
model <- lm(Y ~ X, data)

# Add the fitted line
abline(model)


## using vegan package
library(vegan)
library(dplyr)
library(reshape2) #
library(rgdal)
library(sf)
library(rgeos)
library(tmap)
library(ggplot2)
#reading data csv
df <- data.frame(read.csv("../week5-examples/Camden/tables/CT0010_oa11.csv",sep = ",", skip = 0))

df1 <- df%>%
        select(-CT00100001)

head(df1)
glimpse(df1)

#reshape -->

df1<-melt(df1,ID = 'GeographyCode')

df1<-df1%>%
  filter(GeographyCode =="E00004120")
#calculate diversity for this regions

diversity(df1$value,'shannon')

##how to calculate this for the entire files for each geographic regions
df2<-df%>%
  select(-CT00100001)

nrow(df2[1])

H1 <- matrix(double(1),nrow=nrow(df2[1]),ncol=1)

###
for (i in 1:nrow(df2[1])){
  df3 <- melt(df2[i,],ID='GeographyCode')
  H1[i] <- diversity(df3$value,'shannon')
}

H1
head(H1)
###

df4 <- df%>%
  mutate(shannon = H1,.after = CT00100001)

df4
#adding this to spatial data
OA.Census <- readOGR("Camden/Census_OA_Shapefile.shp")

plot(OA.Census)

head(OA.Census@data)

OA.Census <- merge(OA.Census, df4, by.x="OA11CD", by.y="GeographyCode")

OA.Census_sf <- st_as_sf(OA.Census)

class(OA.Census)

st_write(OA.Census_sf, "Camden/new_OA_cencus.shp", delete_layer = T)

## extra reading materials
#https://rdrr.io/cran/spatialEco/man/shannons.html


###############################################################################
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.
###############################################################################
# Examples for the R/Finance Presentation
# Copyright (C) 2013  Michael Kapler
#
# For more information please visit my blog at www.SystematicInvestor.wordpress.com
# or drop me a line at TheSystematicInvestor at gmail
###############################################################################

#############################################################################
# Cluster Risk Parity
# R/Finance 2013
#############################################################################

# Examine Weights and Risk Contributions
bt.cluster.risk.parity.weights.test <- function()
{
    #*****************************************************************
	# Load historical data for ETFs
	#******************************************************************
	load.packages('quantmod')

	tickers = spl('GLD,UUP,SPY,QQQ,IWM,EEM,EFA,IYR,USO,TLT')

	# map logic
	map = spl('Gold GLD,US Dollar UUP,S&P500 SPY,Nasdaq QQQ,Small Cap IWM,EmergingM EEM,InternationalM EFA,Real Estate IYR,Oil USO,Treasurys TLT')
		names(map) = tickers

	data <- new.env()
	getSymbols(tickers, src = 'yahoo', from = '1900-01-01', env = data, auto.assign = T)
		for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T)

	# map logic
	for(i in ls(data)) data[[ map[i] ]] = data[[i]]
	rm(list=tickers, envir=data)

	bt.prep(data, align='remove.na', dates = '2011:12::2012')

	#*****************************************************************
	# Code Strategies
	#******************************************************************
	periodicity = 'months'
	lookback.len = 250
	cluster.group <<- cluster.group.kmeans.90

	obj = portfolio.allocation.helper(data$prices,
		periodicity = periodicity, lookback.len = lookback.len,
		min.risk.fns = list(
			EW=equal.weight.portfolio,
			RP=risk.parity.portfolio(),
			ERC=equal.risk.contribution.portfolio,

			G2.EW = distribute.weights(equal.weight.portfolio, cluster.group),
			G2.RP=distribute.weights(risk.parity.portfolio(), cluster.group),

			G2.MV=distribute.weights(min.var.portfolio, cluster.group),
			G2.ERC=distribute.weights(equal.risk.contribution.portfolio, cluster.group)
		),
		adjust2positive.definite = F,
		custom.stats.fn = portfolio.allocation.custom.stats.clusters
	)

	#*****************************************************************
	# Create Plots
	#******************************************************************
	clusters = coredata(obj$clusters$EW)[13,]

	# re-map, so that Fixed Income  is red, Currency is blue, Equity is green, Commodity is purple
	temp = clusters
		temp[] = 0
	temp[clusters == clusters[names(clusters) == 'Treasurys TLT']] = 1
	temp[clusters == clusters[names(clusters) == 'US Dollar UUP']] = 2
	temp[clusters == clusters[names(clusters) == 'EmergingM EEM']] = 3
	temp[clusters == clusters[names(clusters) == 'Gold GLD']] = 4
	clusters = temp

png(filename = 'plot1.png', width = 1200, height = 600, units = 'px', pointsize = 12, bg = 'white')

	layout(matrix(1:2,nc=2))

	plot.cluster.weights(coredata(obj$weights$ERC)[13,], clusters,
		main='ERC Weights')

	plot.cluster.weights(coredata(obj$risk.contributions$ERC)[13,], clusters,
		main='ERC Risk Contributions')

dev.off()

png(filename = 'plot2.png', width = 1200, height = 600, units = 'px', pointsize = 12, bg = 'white')

	layout(matrix(1:2,nc=2))

	plot.cluster.weights(coredata(obj$weights$G2.ERC)[13,], clusters,
		main='Cluster ERC Weights')

	plot.cluster.weights(coredata(obj$risk.contributions$G2.ERC)[13,], clusters,
		main='Cluster ERC Risk Contributions')

dev.off()

}

###############################################################################
# Back test for 10 Major Asset Classes
###############################################################################
bt.cluster.risk.parity.10.major.assets <- function()
{
	#*****************************************************************
	# Define universes
	#******************************************************************
	tickers = spl('SPY,EFA,EWJ,EEM,IYR,RWX,IEF,TLT,DBC,GLD')
	dates='2004:12::'
	name = 'ETFs AAA'

	#*****************************************************************
	# Load historical data
	#******************************************************************
	load.packages('quantmod')

	data <- new.env()
	getSymbols(tickers, src = 'yahoo', from = '2000-01-01', env = data, auto.assign = T)
		for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T)

	bt.prep(data, align='keep.all', dates=dates, fill.gaps=T)

	#*****************************************************************
	# Code Strategies
	#******************************************************************
	periodicity = 'weeks'
	lookback.len = 250
	cluster.group <<- cluster.group.kmeans.90

	obj = portfolio.allocation.helper(data$prices,
		periodicity = periodicity, lookback.len = lookback.len,
		min.risk.fns = list(
						EW=equal.weight.portfolio,
						RP=risk.parity.portfolio(),
						ERC=equal.risk.contribution.portfolio,

						Dynamic.EW = distribute.weights(equal.weight.portfolio, cluster.group),
						Dynamic.RP=distribute.weights(risk.parity.portfolio(), cluster.group),
						Dynamic.ERC=distribute.weights(equal.risk.contribution.portfolio, cluster.group)
			),
			adjust2positive.definite = F,
		custom.stats.fn = portfolio.allocation.custom.stats
	)

	models = create.strategies(obj, data, dates=(lookback.len):nrow(data$prices))$models

	#*****************************************************************
	# Create Reports
	#******************************************************************
	title = paste(name, '(' ,periodicity, ',' , lookback.len, 'days )')

	stats = bt.summary.report(models, title, data, obj,
		control = list(
			plot.weight.transition.maps = F,
			plot.risk.contribution.transition.maps = F)
		)

}

###############################################################################
# Back test for stocks in Dow 30 index
###############################################################################
bt.cluster.risk.parity.dow.30 <- function()
{
	#*****************************************************************
	# Load historical data
	#******************************************************************
	load.packages('quantmod')
	dates='1995::'
	name = 'Dow Jones 30'
	data = load.dow.jones(align='keep.all', dates=dates)
		sectors = data$sectors
		tickers = data$symbolnames

	#*****************************************************************
	# Code Strategies
	#******************************************************************
	periodicity = 'weeks'
	lookback.len = 250
	cluster.group <<- cluster.group.kmeans.90

	obj = portfolio.allocation.helper(data$prices,
		periodicity = periodicity, lookback.len = lookback.len,
		min.risk.fns = list(EW=equal.weight.portfolio,
						RP=risk.parity.portfolio(),
						ERC=equal.risk.contribution.portfolio,

						Static.EW = distribute.weights(equal.weight.portfolio, static.group(as.numeric(sectors))),
						Static.RP=distribute.weights(risk.parity.portfolio(), static.group(sectors)),
						Static.ERC=distribute.weights(equal.risk.contribution.portfolio, static.group(sectors)),

						Dynamic.EW = distribute.weights(equal.weight.portfolio, cluster.group),
						Dynamic.RP=distribute.weights(risk.parity.portfolio(), cluster.group),
						Dynamic.ERC=distribute.weights(equal.risk.contribution.portfolio, cluster.group)
			),
			adjust2positive.definite = F,
		custom.stats.fn = portfolio.allocation.custom.stats
	)

	models = create.strategies(obj, data, dates=(lookback.len):nrow(data$prices))$models

	#*****************************************************************
	# Create Reports
	#******************************************************************
	title = paste(name, '(' ,periodicity, ',' , lookback.len, 'days )')

	stats = bt.summary.report(models, title, data, obj,
		control = list(
			plot.weight.transition.maps = F,
			plot.risk.contribution.transition.maps = F)
		)
}

###############################################################################
# Helper Data functions
###############################################################################
load.dow.jones <- function(align='remove.na', dates = NULL) {
	#*****************************************************************
	# Find Sectors for each company in DOW 30
	#******************************************************************
	tickers = spl('XLY,XLP,XLE,XLF,XLV,XLI,XLB,XLK,XLU')
	tickers.desc = spl('ConsumerCyclicals,ConsumerStaples,Energy,Financials,HealthCare,Industrials,Materials,Technology,Utilities')

	sector.map = c()
	for(i in 1:len(tickers)) {
		sector.map = rbind(sector.map,
				cbind(sector.spdr.components(tickers[i]), tickers.desc[i])
			)
	}
	colnames(sector.map) = spl('ticker,sector')

	#*****************************************************************
	# Load historical data
	#******************************************************************
	load.packages('quantmod')
	tickers = dow.jones.components()

	sectors = factor(sector.map[ match(tickers, sector.map[,'ticker']), 'sector'])
		names(sectors) = tickers

	data <- new.env()
	getSymbols(tickers, src = 'yahoo', from = '1900-01-01', env = data, auto.assign = T)
		for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T)

	bt.prep(data, align=align,dates=dates)

	# re-order sectors, because bt.prep can change the order of tickers
	data$sectors = sectors[data$symbolnames]

	return(data)
}

###############################################################################
# Helper Back-test functions
###############################################################################
# compute portfolio allocation additional stats
portfolio.allocation.custom.stats.clusters <- function(x,ia) {
	risk.contributions = portfolio.risk.contribution(x, ia)
	clusters = cluster.group(ia)
	return(list(
		# vectors
		risk.contributions = risk.contributions,
		clusters = clusters,

		# numbers
		ncluster = max(clusters)
	))
}

# create back-test report
bt.summary.report <- function(models, title, data, obj=NULL,
	control = list(
		plot.weight.transition.maps = F,
		plot.risk.contribution.transition.maps = !is.null(obj)
	)
) {
	#*****************************************************************
	# Setup
	#******************************************************************
	if(is.null(control$plot.weight.transition.maps)) control$plot.weight.transition.maps = F
	if(is.null(control$plot.risk.contribution.transition.maps)) control$plot.risk.contribution.transition.maps = obj!=NULL

    filename = title
    filename.pdf = paste(filename, '.pdf', sep='')
    filename.csv = paste(filename, '.csv', sep='')

    # put all reports into one pdf file
	pdf(file = filename.pdf, width=8.5, height=11)

	#*****************************************************************
	# Create Plots
	#******************************************************************
	layout(1:2)
	plotbt(models, plotX = T, log = 'y', LeftMargin = 3, main = title)
		mtext('Cumulative Performance', side = 2, line = 1)

	out = plotbt.strategy.sidebyside(models, return.table=T)

	#*****************************************************************
	# Create Table
	#******************************************************************
	# Composite Diversification Indicator
	cdi = custom.composite.diversification.indicator(obj, plot.main = F, plot.table = F)
		out = rbind(colMeans(cdi, na.rm=T), out)
		rownames(out)[1] = 'Composite Diversification Indicator(CDI)'

	# Portfolio Turnover
	y = 100 * sapply(models, compute.turnover, data)
		out = rbind(y, out)
		rownames(out)[1] = 'Portfolio Turnover'

	# Bar chart in descending order of the best algos
	performance.barchart.helper(out, 'Sharpe,Cagr,DVR,MaxDD,Volatility,Portfolio Turnover,Composite Diversification Indicator(CDI)', c(T,T,T,T,F,F,T))

	#*****************************************************************
	# Create Plots
	#******************************************************************

	# Plot transition maps
	if(control$plot.weight.transition.maps) {
		#layout(1:len(models))
		layout(1:4)
		for(m in names(models)) {
			plotbt.transition.map(models[[m]]$weight, name=m)
				legend('topright', legend = m, bty = 'n')
		}
	}

	# Plot transition maps for Risk Contributions
	if(control$plot.risk.contribution.transition.maps) {
		dates = index(data$prices)[obj$period.ends]
		layout(1:4)
		for(m in names(models)) {
			plotbt.transition.map(make.xts(obj$risk.contributions[[m]], dates),
			name=paste('Risk Contributions',m))
				legend('topright', legend = m, bty = 'n')
		}
	}

	# close pdf file
    dev.off()

	#*****************************************************************
	# save summary & equity curves into csv file
	#******************************************************************
	load.packages('abind')
	append=FALSE

	cat(title, '\n', file=filename.csv, append=append)
	write.table(out, sep=',',  row.names = , col.names = NA, file=filename.csv, append=TRUE)
	cat('\n\n', file=filename.csv, append=TRUE)

	if(F) {
		out = abind(lapply(models, function(m) m$equity))
			colnames(out) = names(models)
		write.xts(make.xts(out, index(models[[1]]$equity)), filename.csv, append=TRUE)
	}

	return(out)
}

#############################################################################
# Helper plot functions
#############################################################################
# pie.labels function override to allow trnaparent background
pie.labels.fix <- function (x, y, angles, labels, radius = 1, ...) {
	par(xpd = TRUE)
	    xylim <- par("usr")
	    plotdim <- par("pin")
	    yradius <- radius * (xylim[4] - xylim[3])/(xylim[2] - xylim[1]) * plotdim[1]/plotdim[2]
	    xc <- cos(angles) * radius + x
	    yc <- sin(angles) * yradius + y
	    text(xc, yc, labels, ...)
    par(xpd = FALSE)
}

# plot pie charts weight / clusters
plot.cluster.weights <- function(weight, clusters, main='') {
	load.packages('RColorBrewer,plotrix')

	clusters = sort(clusters)
	weight = weight[names(clusters)]
	weight.cluster = tapply(weight,clusters,sum)

	counts = tapply(names(clusters),clusters,len)
		ncluster = len(counts)

	require(RColorBrewer)
	colors = colorRampPalette(brewer.pal(iif(ncluster>9,9,ncluster),'Set1'))(ncluster)
		#  plot(1:len(colors), col=colors, lwd=40)

	cols = c()
	for(i in 1:ncluster) cols = c(cols, col.add.alpha(colors[i], seq(200,100,length.out = counts[i])))

	if(F) {
		plot(-1:1 ,-1:1, main=main, type='n', yaxt = 'n', xaxt = 'n', xlab = '', ylab = '', axes = F)
		bisect.angles = floating.pie(0,0,weight, col=cols, border='white', radius=0.9, cex=0.8)
		pie.labels(0,0,bisect.angles,names(weight),radius=1,bg=0,border=F, srt=bisect.angles)
	}

	par(mar = c(2,2,2,2))
	pie(weight, col=cols, border='white', radius=0.9, main=main)

	require(plotrix)
	bisect.angles = floating.pie(0,0,weight.cluster,radius=0.5,col=colors,border='white')
	pie.labels.fix(0,0,bisect.angles,paste(round(100*weight.cluster,0),'%',sep=''),radius=0.2)
}


LISP Interpreter Run

[[[[[

 A LISP expression that asserts that it itself is unprovable!

 Let g(x): x -> (is-unprovable (value-of (('x)('x))))

 Then (is-unprovable (value-of (('g)('g))))
 asserts that it itself is not a theorem!

]]]]]

define (g x)
   let (L x y) cons x cons y nil [Makes x and y into list.]
   (L is-unprovable (L value-of (L (L "' x) (L "' x))))

define      g
value       (lambda (x) ((' (lambda (L) (L is-unprovable (L va
            lue-of (L (L ' x) (L ' x)))))) (' (lambda (x y) (c
            ons x (cons y nil))))))

[Here we try g:]

(g x)

expression  (g x)
value       (is-unprovable (value-of ((' x) (' x))))

[
 Here we calculate the LISP expression
 that asserts its own unprovability:
]

(g g)

expression  (g g)
value       (is-unprovable (value-of ((' (lambda (x) ((' (lamb
            da (L) (L is-unprovable (L value-of (L (L ' x) (L
            ' x)))))) (' (lambda (x y) (cons x (cons y nil))))
            ))) (' (lambda (x) ((' (lambda (L) (L is-unprovabl
            e (L value-of (L (L ' x) (L ' x)))))) (' (lambda (
            x y) (cons x (cons y nil))))))))))

[Here we extract the part that it uses to name itself:]

cadr cadr (g g)

expression  (car (cdr (car (cdr (g g)))))
value       ((' (lambda (x) ((' (lambda (L) (L is-unprovable (
            L value-of (L (L ' x) (L ' x)))))) (' (lambda (x y
            ) (cons x (cons y nil))))))) (' (lambda (x) ((' (l
            ambda (L) (L is-unprovable (L value-of (L (L ' x)
            (L ' x)))))) (' (lambda (x y) (cons x (cons y nil)
            )))))))

[Here we evaluate the name to get back the entire expression:]

eval cadr cadr (g g)

expression  (eval (car (cdr (car (cdr (g g))))))
value       (is-unprovable (value-of ((' (lambda (x) ((' (lamb
            da (L) (L is-unprovable (L value-of (L (L ' x) (L
            ' x)))))) (' (lambda (x y) (cons x (cons y nil))))
            ))) (' (lambda (x) ((' (lambda (L) (L is-unprovabl
            e (L value-of (L (L ' x) (L ' x)))))) (' (lambda (
            x y) (cons x (cons y nil))))))))))

[Here we check that it worked:]

= (g g) eval cadr cadr (g g)

expression  (= (g g) (eval (car (cdr (car (cdr (g g)))))))
value       true

End of LISP Run

Elapsed time is 0 seconds.


library(tidyverse)

ggplot(data=mpg) + geom_point(aes(x=displ,y=hwy), color="#00abff") + theme_bw()
ggplot(data=mpg) + geom_point(aes(x=displ,y=hwy,colour=class)) + theme_bw()
ggplot(data=mpg) + geom_point(aes(x=displ,y=hwy,alpha=class))
ggplot(data=mpg) + geom_point(aes(x=displ,y=hwy,shape=class))

# 分面
ggplot(data=mpg) + geom_point(aes(x=displ,y=hwy)) + facet_wrap(~ drv,nrow = 2)
ggplot(data=mpg) + geom_point(aes(x=displ,y=hwy)) + facet_grid(drv~.)

df <- data.frame(
  x = rnorm(120,c(0,2,4)),
  y = rnorm(120,c(1,2,1)),
  z = letters[1:3]
)

ggplot(data = df) + geom_point(aes(x,y,color=z))

ggplot(data = df) + geom_point(aes(x,y)) + facet_wrap(~z)

df_sum <- df %>%
  group_by(z) %>%
  summarise(x=mean(x),y=mean(y)) %>%
  rename(z2=z)
ggplot(df,aes(x,y)) +
  geom_point(aes(color=z)) +
  geom_point(data=df_sum,aes(color=z2,size=4)) +
  facet_wrap(~z)

# 将数据放在同一个背景板中
df2 <- select(df,-z)
ggplot(df,aes(x,y)) +
  geom_point(data=df2,color='grey70') +
  geom_point(aes(color=z)) +
  facet_wrap(~z)

# 几何对象

ggplot(data=mpg,mapping=aes(x=displ,y=hwy)) +
  geom_point(aes(color=drv)) +
  geom_smooth(mapping = aes(x=displ,y=hwy)) +
  geom_smooth(mapping = aes(x=displ,y=hwy,linetype=drv,color=drv),
              method = 'loess')

# 将一组变量传递给ggplot函数，ggplot将这些映射作为全局映射应用到图中的每个几何对象中
# 如果将映射放在几何对象函数中，ggplot2会将其视作这个图层的局部映射
# 以下的写法跟上面的结果一样
ggplot(data=mpg,mapping=aes(x=displ,y=hwy)) +
  geom_point(aes(color=drv)) +
  geom_smooth() +
  geom_smooth(mapping = aes(linetype=drv,color=drv),method = 'loess')

ggplot(data=mpg,mapping = aes(x=displ,y=hwy)) +
  geom_smooth(mapping = aes(color=drv),
              show.legend = T)

ggplot(data=mpg,mapping = aes(x=displ,y=hwy)) +
  geom_point(aes(color=class)) +
  geom_smooth(data=filter(mpg,class=="subcompact"),se=F)

# p17,(6)
# a:
ggplot(data=mpg,aes(x=displ,y=hwy)) +
  geom_point() +
  geom_smooth(se=F)

# b:
ggplot(data=mpg,aes(x=displ,y=hwy)) +
  geom_point() +
  geom_smooth(mapping=aes(group=drv),se=F)

# c:
ggplot(data=mpg,aes(x=displ,y=hwy,color=drv)) +
  geom_point() +
  geom_smooth(mapping=aes(color=drv),se=F)

# d:
ggplot(data=mpg,aes(x=displ,y=hwy)) +
  geom_point(aes(color=drv)) +
  geom_smooth(se=F)

# e:
ggplot(data=mpg,aes(x=displ,y=hwy)) +
  geom_point(aes(color=drv)) +
  geom_smooth(mapping=aes(linetype=drv),se=F)

# f:
ggplot(data=mpg,aes(x=displ,y=hwy,color=drv)) +
  geom_point()

# 统计变换
ggplot(data=diamonds) +
  geom_bar(aes(x=cut,fill=cut),show.legend = F)

ggplot(data=diamonds) +
  stat_count(aes(x=cut,fill=cut,alpha=cut),show.legend = T)

demo <- tribble(
  ~a,~b,
  "bar_1",20,
  "bar_2",30,
  "bar_3",40
)

ggplot(data=demo) +
  geom_bar(aes(x=a,y=b),stat="identity")

# 图像排版使用patchwork，
# 教程参考链接：https://cloud.tencent.com/developer/article/1889233
library(patchwork)

p <- ggplot(data=diamonds) +
  geom_bar(mapping = aes(x=cut,fill=clarity),position = 'fill') +
  theme_bw()

library(scales)
cols = hue_pal()(8)
p1 <- ggplot(data=diamonds) +
  geom_bar(mapping = aes(x=cut,fill=clarity),position = 'fill') +
  scale_fill_manual(values = cols) +
  theme_bw()

p + p1

p3 <- ggplot(data=diamonds,mapping = aes(x=carat,y=price)) +
  scale_color_manual(values=hue_pal()(7)) +
  geom_point(aes(color=color)) +
  geom_smooth(aes(group=color,color=color),se=F) +
  theme_bw()

design <- "
  1122
  3333
  3333
"
p_out <- p + p1 + p3 +
  plot_layout(design = design) +
  plot_annotation(tag_levels="A")

# 图片保存使用ggsave
ggsave(filename = "out.png",plot=p_out,width = 25,height = 16,
       units = 'cm',dpi = 600)

SYMBOL <- c("EEF1A1","EEF1A1","HSP")
FC <- c(10.266615,9.228078,8.26)
P.value <- c(6.42e-07,4.31e-07,4.12e-07)
rwl <- data.frame()

library(tidyverse)
qz <- read.csv("qz.csv")

uniq_qz <- qz %>% group_by(Symbol) %>%
  summarise(logFC_=median(logFC),p_=median(p))

qz <- read.csv("qz.csv")
attach(qz)
aggregate(qz[2:3],by=list(Symbol),FUN=median,na.rm=TRUE)

# 使用aRtsy包画艺术图
devtools::install_github("koenderks/aRtsy")
library(aRtsy)

# 用R这么画基因结构图
# https://zhuanlan.zhihu.com/p/83092046

# install.packages("gggenes")
library(gggenes)
head(example_genes)

ggplot(example_genes, aes(xmin = start, xmax = end,
                          y = molecule, fill = gene)) +
  geom_gene_arrow() +
  facet_wrap(~ molecule, scales = "free", ncol = 1) +
  scale_fill_brewer(palette = "Set3") +
  theme_genes()

ggplot(example_genes, aes(xmin = start, xmax = end,
                          y = molecule, fill = gene, label = gene, forward = orientation)) +
  geom_gene_arrow() +
  facet_wrap(~ molecule, scales = "free", ncol = 1) +
  scale_fill_brewer(palette = "Set3") +
  theme_genes() +
  geom_gene_label(align = "left")

# 展示展现基因结构域特征或者比对信息
# 需要另外的信息example_subgenes
head(example_subgenes)
ggplot(example_genes, aes(xmin = start, xmax = end, y = molecule)) +
  facet_wrap(~ molecule, scales = "free", ncol = 1) +
  geom_gene_arrow(fill = "white") +
  geom_subgene_arrow(data = example_subgenes,
                     aes(xmin = start, xmax = end, y = molecule, fill = gene,
                         xsubmin = from, xsubmax = to), color="black", alpha=.7) +
  theme_genes()

# geom_bar默认位置调整是geom_stack

# 位置调整：fill
cols = hue_pal()(8)
p_fill <- ggplot(data=diamonds) +
  geom_bar(mapping = aes(x=cut,fill=clarity),position = 'fill') +
  scale_fill_manual(values = cols) +
  theme_bw()

# 位置调整：dodge
library(scales)
library(patchwork)
cols = hue_pal()(8)
p_dodge <- ggplot(data=diamonds) +
  geom_bar(mapping = aes(x=cut,fill=clarity),position = 'dodge') +
  scale_fill_manual(values = cols) +
  theme_bw()

p_fill + p_dodge

# 位置调整：jitter
# 增加随机扰动，将重叠的点分散开来
ggplot(data=mpg) +
  geom_point(mapping = aes(x=displ,y=hwy),
             position = 'jitter')

ggplot(data=mpg) +
  geom_point(mapping = aes(x=displ,y=hwy),position = 'count')

# 坐标系

## coord_flip()交换x轴和y轴

p <- ggplot(data = mpg,mapping = aes(x=class,y=hwy)) +
  geom_boxplot()

p + coord_flip()

## coord_polar()使用极坐标系

bar <- ggplot(data=diamonds,mapping=aes(x=cut,fill=cut)) +
  geom_bar(show.legend = F,width = 1) +
  theme(aspect.ratio = 1) +
  labs(x=NULL,y=NULL)

bar + coord_flip()
blank_theme <- theme_minimal()+
  theme(
    axis.title.x = element_blank(),
    axis.title.y = element_blank(),
    axis.text.x = element_blank(),
    axis.text.y = element_blank(),
    panel.border = element_blank(),
    panel.grid=element_blank(),
    axis.ticks = element_blank(),
    plot.title=element_text(size=14, face="bold")
  )
bar + coord_polar() + blank_theme + scale_fill_manual(values=hue_pal()(5))
# 使用coord_polar将堆叠式条形图转换成饼图
ggplot(data=diamonds,mapping = aes(x='cut',fill=cut)) +
  geom_bar(stat="count",width = 1,position = 'stack') +
  coord_polar("y", start=0) +
  blank_theme +
  scale_fill_manual(values=hue_pal()(5)) +
  geom_text(stat="count",aes(label = scales::percent(..count../50)), size=3, position=position_stack(vjust = 0.5))


# script can be executed with
library(sf)
library(readr)
library(ggplot2)
library(dplyr)
library(lubridate)
library(rdwd)
library(ggmap)

temps = read_csv("saxony-monthly-temperature.csv")

#find common stations from 1951 - 2017
stats51 = temps %>%
    mutate(yr= as.integer(year(ymd(MESS_DATUM_BEGINN))),
           mo= as.integer(month(ymd(MESS_DATUM_BEGINN)))) %>%
    filter(yr == 1951, mo == 7)

stats17 = temps %>%
    mutate(yr= as.integer(year(ymd(MESS_DATUM_BEGINN))),
           mo= as.integer(month(ymd(MESS_DATUM_BEGINN)))) %>%
    filter(yr == 2017, mo == 7)

#find stations that are common in both years
common = intersect(stats51$STATIONS_ID,stats17$STATIONS_ID)

#crosscheck
cat(paste(common))

stations = temps %>%
    select(STATIONS_ID, geo_lat, geo_lon, height, name)%>%
    unique()

#compute median of reference years 1951 to 1981
ref_median_year = temps %>%
    mutate(yr= as.integer(year(ymd(MESS_DATUM_BEGINN))),
           mo= as.integer(month(ymd(MESS_DATUM_BEGINN)))) %>%
    filter(yr > 1950 & yr < 1982, ! is.na(MO_TT), STATIONS_ID %in% common) %>%
    group_by(STATIONS_ID, mo) %>%
    summarize( refmedian = median(MO_TT), refmax = median(MO_TX))

                                        #TODO: add german map
#https://nceas.github.io/oss-lessons/spatial-data-gis-law/3-mon-intro-gis-in-r.html
temps_station = temps %>%
    mutate(yr= as.integer(year(ymd(MESS_DATUM_BEGINN))), mo= month(ymd(MESS_DATUM_BEGINN))) %>%
    filter(yr > 1945, ! is.na(MO_TT) , STATIONS_ID %in% common) %>%
    left_join(ref_median_year, by=c('STATIONS_ID' = 'STATIONS_ID', 'mo' = 'mo')) %>%
    mutate( anom = MO_TT - refmedian, max_anom = MO_TX - refmax ) %>%
    group_by(STATIONS_ID,yr) %>%
    summarize( anom_total     = round(sum(anom),0),
               max_anom_total = round(sum(max_anom),0),
               anom_median    = round(median(anom),0),
               max_anom_median= round(median(max_anom),0)
              ) %>%
    left_join(stations, by=c('STATIONS_ID' = 'STATIONS_ID')) %>%
    filter(yr == 2017)

head(temps_station)

                                        #shapes obtained from
                                        # https://www.arcgis.com/home/item.html?id=ae25571c60d94ce5b7fcbf74e27c00e0
                                        #https://geocompr.robinlovelace.net/read-write.html
bld = st_read('shapes/vg2500_bld.shx')
sachsen.df = as.data.frame(bld) %>% filter(GEN == 'Sachsen')
sachsen.st = st_as_sf(sachsen.df)

## help(st_read)
sac <- sf::st_read("shapes/vg2500_bld.shp", quiet = TRUE)  %>% filter(GEN %in% "Sachsen")
## ggsave("sachsen.png",ggplot(sac ) + geom_sf())

#http://strimas.com/r/tidy-sf/
anplot = ggplot(sac) + #ggplot(temps_station,aes(x=geo_lon,y=geo_lat,color=anom_median)) +
    geom_sf() +
  geom_point(data=temps_station,aes(x=geo_lon,y=geo_lat,color=anom_median))  +
  geom_sf_label(data=temps_station,aes(label = name)) +
#    theme_minimal() +
    scale_color_gradient2(midpoint=0, low="blue", mid="white",
                           high="red", space ="Lab" ) +
                                        #scale_color_gradientn(colors=rev(rainbow(5))) +

    xlab("Laenge") + xlim(min(temps_station$geo_lon)*.98,max(temps_station$geo_lon)*1.02) +
    ylab("Breite") + ylim(min(temps_station$geo_lat)*.98,max(temps_station$geo_lat)*1.02) +
    ggtitle("Jahr: 2018, mittlere Temperaturanomalie des Monatsmittel im Vergleich zu 1950-1981")

ggsave("2018-temperatures.png",anplot)


# simulate the size for testing
type_1 <- function(seed = 2021087, k, n, m, L = 1000, mixed = T, ...) {
    sim.success <- 0
    sim.stats <- c()
    sim.sigma2 <- c()
    sim.c0 <- c()
    sim.calt <- c()
    l_time <- list()
    times <- seq(-1, 1, length.out = 80) # all possible time points
    cov_truth <- 1 + tcrossprod(times) - 0.5 * times - 0.5 * matrix(rep(times, 80), 80, byrow = T)

    while (sim.success < k) {
        set.seed(seed + sim.success)
        data <- gen.data(nsubj = n, r = 0, M = m, mixed_m = mixed)
        l_time[[sim.success + 1]] <- try(system.time(
            face.b <- bootstrap.face(data, nbs = L, argvals.new = times, ...))[1:3],
            silent = T)
        if ("try-error" %in% class(l_time[[sim.success + 1]])) {# issue with null fit
            seed <- seed + 1
            next
        }
        sim.success <- sim.success + 1
        sim.stats <- c(sim.stats, face.b$p)
        sim.sigma2 <- c(sim.sigma2, face.b$sigma2)
        sim.c0 <- c(sim.c0, norm(face.b$C.null - cov_truth, type = "F"))
        sim.calt <- c(sim.calt, norm(face.b$C.alt - cov_truth, type = "F"))
    }

    list(c(mean(sim.stats <= 0.05), mean(sim.stats <= 0.1)),
        mean((sim.sigma2 - 1)^2),
        mean(sim.c0),
        mean(sim.calt),
        rowMeans(matrix(unlist(l_time), nrow = 3)),
        c(seed, sim.success),
        sim.stats)
}

# simulate the size for testing
type_2 <- function(seed = 2021087, k, n, m, dev, r, L = 1000, mixed = T, ...) {
    sim.success <- 0
    sim.stats <- c()
    sim.sigma2 <- c()
    sim.c0 <- c()
    sim.calt <- c()
    l_time <- list()
    times <- seq(-1, 1, length.out = 80) # all possible time points
    cov_truth <- 1 + tcrossprod(times) - 0.5 * times - 0.5 * matrix(rep(times, 80), 80, byrow = T) + r *
    while (sim.success < k) {
        set.seed(seed + sim.success)
        data <- gen.data(deviation = dev, nsubj = n, r = r, M = m, mixed_m = mixed)
        l_time[[sim.success + 1]] <- try(system.time(
            face.b <- bootstrap.face(data, nbs = L, argvals.new = times, ...))[1:3],
            silent = T)
        if ("try-error" %in% class(l_time[[sim.success + 1]])) {# issue with null fit
            seed <- seed + 1
            next
        }
        sim.success <- sim.success + 1
        sim.stats <- c(sim.stats, face.b$p)
        sim.sigma2 <- c(sim.sigma2, face.b$sigma2)
        sim.c0 <- c(sim.c0, norm(face.b$C.null - cov_truth, type = "F"))
        sim.calt <- c(sim.calt, norm(face.b$C.alt - cov_truth, type = "F"))
    }
    list(mean(sim.stats <= 0.05),
        mean((sim.sigma2 - 1)^2),
        mean(sim.c0),
        mean(sim.calt),
        rowMeans(matrix(unlist(l_time), nrow = 3)),
        c(seed, sim.success),
        sim.stats)
}


setwd("/home/brito/salt/JSRepairClass/input/applications/")
data <- read.csv("repositories_metrics.csv")
hist(data$TotalCommits, main = paste("Histogram for ", nrow(data), "node.js applications"), xlab = "Total number of commits")

setwd("/home/brito/salt/JSRepairClass/input/modules/")
data <- read.csv("repositories_metrics.csv")
hist(data$TotalCommits, main = paste("Histogram of", nrow(data), "top rated node.js modules (from npmjs.com)"), xlab = "Total number of commits")


#'@title Return the four digit year for each element of a given time series
#'
#'@description The function \code{time} in the \cr\code{stats} package returns the date in fractions.
#'             This function converts that value to the proper four digit integer.
#'
#'@usage  year <- getYear(tsData)
#'
#'@param tsData  A Time Series Object.
#'
#'@return A vector of 4 digit integers (representing years).
#'
#'@export

getTsYear <- function(tsData)
{
 	return (floor(time(tsData)))
}


Network Graphs in R

We are using the well-known social network of Zachary's karate club. GML format file can be collected from here.

read graph file and update layout

library(igraph)
library(plotly)

G <- read.graph("karate.gml", format = c("gml"))
L <- layout.circle(G)
vertices and edges for the graph

vs <- V(G)
es <- as.data.frame(get.edgelist(G))
count of vertices and edges

Nv <- length(vs)
Ne <- length(es[1]$V1)
node positions

Xn <- L[,1]
Yn <- L[,2]
draw network nodes

network <- plot_ly(type = "scatter", x = Xn, y = Yn, mode = "markers", text = vs$label, hoverinfo = "text")
creates shapes for edges

edge_shapes <- list()
for(i in 1:Ne) {
  v0 <- es[i,]$V1
  v1 <- es[i,]$V2

  edge_shape = list(
    type = "line",
    line = list(color = "#030303", width = 0.3),
    x0 = Xn[v0],
    y0 = Yn[v0],
    x1 = Xn[v1],
    y1 = Yn[v1]
  )

  edge_shapes[[i]] <- edge_shape
}
add edges to the network

network <- layout(
  network,
  title = 'Karate Network',
  shapes = edge_shapes,
  xaxis = list(title = "", showgrid = FALSE, showticklabels = FALSE, zeroline = FALSE),
  yaxis = list(title = "", showgrid = FALSE, showticklabels = FALSE, zeroline = FALSE)
)

network


#' Calculates several measures of fit for Linear Mixel Models
#' based on Lou and Azen (2013) text.
#' Models could be lmer or lme models
#' @param m.null Null model (only with random intercept effects)
#' @param m.full Full model
#' @return lmmR2 class
#' @export
lmmR2<-function(m.null, m.full) {
	if(is(m.null,"lme"))	 {
		return(lmmR2.lme(m.null,m.full))
	} else if (class(m.null)=="mer" | class(m.null)=="lmerMod" | class(m.null)=="lmerTest") {
		return(lmmR2.mer(m.null,m.full))
	} else {
		stop("Not implemented for other classes than lme or lmer")
	}
}

# Calcula los cuatro R^2 presentes en el texto de Lou y Azen (2013).
# Debo extraer los interceptos para los modelos
lmmR2.mer<-function(m.null,m.full) {
	# Primero, verifico que tengan la misma estructura de grupos. Si
	# no, estoy puro leseando
	v.0<-lme4::VarCorr(m.null)
	v.1<-lme4::VarCorr(m.full)
	if(!all.equal(names(v.0),names(v.1))) {
		stop("Groups should be equal")
	}
	n.b<-length(names(v.0))
	# recojo los sigmas
	sigmas=c(sigma(m.null)^2,sigma(m.full)^2)
	# recojo los thetas
	thetas.0=sapply(v.0,function(x) {x[1,1]})
	thetas.1=sapply(v.1,function(x) {x[1,1]})
	# recojo el largo promedio
	nn=sapply(m.null@flist,function(x) {
		length(levels(x)) / sum(1/table(x))
	})
	rb.r2.1<-1-(sigmas[2]/sigmas[1])
	rb.r2.2<-1-(sum(thetas.1)/sum(thetas.0))
	sb.r2.1<-1-((sigmas[2]+sum(thetas.1))/(sigmas[1]+sum(thetas.0)))
	sb.r2.2<-1-(  sigmas[2]+sum(thetas.1*nn)) / (sigmas[1]+sum(thetas.0*nn))
	out<-list(sigmas=sigmas,t0=thetas.0,t1=thetas.1, nn=nn, rb.r2.1=rb.r2.1, rb.r2.2=rb.r2.2, sb.r2.1=sb.r2.1, sb.r2.2=sb.r2.2)
	class(out)<-"lmmR2"
	out
}
# Extractor de varianzas para nlme
vars.lme<-function(x) {
	vv<-nlme::VarCorr(x)
	# Si tiene solo dos filas, recoge un solo factor
	if(nrow(vv)==2) {
		out=list()
		out[[colnames(x$groups)]]=as.numeric(vv[1,1])
		return(out)
	} else {
		out=list()
		vv.n<-rownames(vv)
		current.var=NULL
		for(i in 1:nrow(vv)) {
			c.name=vv.n[i]
			#print(vv.n[i])
			aa=grep("(.+) =",c.name,value=T)
			if(length(aa)) {
				aa=sub(" =","",aa)
				current.var=aa
			} else if(!is.null(current.var) & c.name=="(Intercept)") {
				out[[current.var]]=vv[i,1]
			}
		}
		out
	}
}
# Debo extraer los interceptos para los modelos
lmmR2.lme<-function(m.null,m.full) {
	# Primero, verifico que tengan la misma estructura de grupos. Si
	# no, estoy puro leseando
	v.0<-vars.lme(m.null)
	v.1<-vars.lme(m.full)
	if(!all.equal(names(v.0),names(v.1))) {
		stop("Groups should be equal")
	}

	n.b<-length(names(v.0))
	# recojo los sigmas
	sigmas=c(m.null$sigma^2,m.full$sigma^2)
	# recojo los thetas
	thetas.0=sapply(v.0,function(x) {as.numeric(x[1])})
	thetas.1=sapply(v.1,function(x) {as.numeric(x[1])})
	#print(thetas.0)
	#print(thetas.1)
	# recojo el largo promedio
	nn=sapply(m.null$groups,function(x) {
		length(levels(x)) / sum(1/table(x))
	})

	rb.r2.1<-1-(sigmas[2]/sigmas[1])
	rb.r2.2<-1-(sum(thetas.1)/sum(thetas.0))
	sb.r2.1<-1-((sigmas[2]+sum(thetas.1))/(sigmas[1]+sum(thetas.0)))
	sb.r2.2<-1-(  sigmas[2]+sum(thetas.1*nn)) / (sigmas[1]+sum(thetas.0*nn))
	out<-list(sigmas=sigmas,t0=thetas.0,t1=thetas.1, nn=nn,rb.r2.1=rb.r2.1, rb.r2.2=rb.r2.2, sb.r2.1=sb.r2.1, sb.r2.2=sb.r2.2)
	class(out)<-"lmmR2"
	out
}

#' @export
print.lmmR2<-function(x) {
	print(summary.lmmR2(x))
}

#' @export
print.summary.lmmR2<-function(xx) {
	cat("Explanatory power of Multilevel Model\n")
	cat("=====================================\n")
	cat("Variances:\n")
	print(xx$m1)
	cat("Indexes:\n")
	print(xx$m2,row.names=F)
	cat("\n")

}

#' @export
summary.lmmR2<-function(x) {

  v.null<-c(x$sigmas[1],x$t0)
  v.full<-c(x$sigmas[2],x$t1)

	m1<-data.frame(avg.size=c(1,x$nn),null=v.null, null.r=v.null/(sum(v.null)),  full=v.full, pseudo.r2= 1-(v.full/v.null) )
	#cat("Variances:\n")
	rownames(m1)[1]<-"Residual"
	#print(m1)
	#cat("Indexes:\n")
	m2<-with(x, data.frame(indexes=c("R & B R1","R & B R2","S & B R1","S & B R2"),
	meaning=c("Within-cluster variance(relative)",
	"Between-cluster variance(relative)",
	"Reduce individual error(total)",
	"Reduce cluster error(total)"
	),
	vals=c(rb.r2.1,rb.r2.2,sb.r2.1,sb.r2.2)))
	#print(m2, row.names=F)
	out=list(m1=m1,m2=m2)

	class(out)<-"summary.lmmR2"
	return(out)
}


fib2 <- function(n) {
  (n >= 0) || stop("bad argument")
  ( function(n) if (n <= 1) 1 else Recall(n-1)+Recall(n-2) )(n)
}


##import the data file
##you can import by clicking import dataset > follow instructions
##you can also use the handy file.choose() option
##note that window sometimes hides behind rstudio, so minimize to find it
datafile = read.csv(file.choose())
##don't run line 5 if you use the import option

##install the packages if you don't have them
##you only have to install the package once, unless you update R
install.packages("reshape")
install.packages("nlme")
install.packages("ggplot2")

##you will want to run this code every time you open R
##and definitely if it crashes
library(nlme)
library(reshape)
library(ggplot2)

##factor our categorical IV
table(datafile$intervention)
datafile$intervention = factor(datafile$intervention,
                               levels = c(0,1,2),
                               labels = c("None", "Type 1", "Type 2"))

##this particular data is half-wide, half-long
##each day/time has a row already, but we want to make all the DVs one column too
longdata = melt(datafile,
                id = c("day","time","partno","intervention"),
                measured = c("thighs","sucked","stomach","compare","mirror","jiggle","spread", "weight"))

##one bad thing about melt is the naming of the columns
##you can change them, but this code will assume you didn't
##variable = all the labels of the columns you put into measured
##value = the actual scores from those columns (DV)

##intercept only model
##gls = generalized least squares
##ML = maximum likelihood
model1 = gls(value ~ 1,
             data = longdata,
             method = "ML",
             na.action = "na.omit")
summary(model1)

##random intercept only model
##note we switched to LME function
model2 = lme(value ~ 1,
             data = longdata,
             method = "ML",
             na.action = "na.omit",
             random = ~1|partno)
summary(model2)

##compare those two models
anova(model1, model2)

##if significant --> go on to test other random effects if necessary
##example adding more levels of nesting, higher order go first
model2.1 = lme(value ~ 1,
             data = longdata,
             method = "ML",
             na.action = "na.omit",
             random = list(~1|time, ~1|partno))
summary(model2.1)
##if significant comparison --> go on to fixed effects
##if not --> ANOVA is A-OK. (in theory, not necessarily in practice)

##add fixed effects to your model
model3 = lme(value ~ intervention,
             data = longdata,
             method = "ML",
             na.action = "na.omit",
             random = ~1|partno)
summary(model3)

##compare all the models
anova(model1, model2, model3)

##how would I add other IV variables?
model3.1 = lme(value ~ intervention + time,
             data = longdata,
             method = "ML",
             na.action = "na.omit",
             random = ~1|partno)
summary(model3.1)

##random slope model
model4 = lme(value ~ intervention + time,
             data = longdata,
             method = "ML",
             na.action = "na.omit",
             random = ~time|partno,
             control = lmeControl(msMaxIter = 200))
summary(model4)

##compare models
anova(model1,model2,model3,model4)

##I made a pretty graph of the data
##Please see graphs/scatterplots for how to make this picture
library(ggplot2)

cleanup = theme(panel.grid.major = element_blank(),
                panel.grid.minor = element_blank(),
                panel.background = element_blank(),
                axis.line = element_line(color = "black"))

scatter = ggplot(longdata, aes(time, value, color = intervention, fill = intervention))
scatter +
  cleanup +
  geom_point() +
  geom_smooth(method = "lm") +
  xlab("Time of Measurement") +
  ylab("Body Checking Behavior Count") +
  scale_fill_discrete(name = "Intervention Type") +
  scale_color_discrete(name = "Intervention Type")

scatter = ggplot(longdata, aes(time, value, color = as.factor(partno), fill = as.factor(partno)))
scatter +
  cleanup +
  geom_point() +
  geom_smooth(method = "lm") +
  xlab("Time of Measurement") +
  ylab("Body Checking Behavior Count") +
  scale_fill_discrete(name = "Participant Number") +
  scale_color_discrete(name = "Participant Number")


#' rcond
#'
#' Compute matrix norm.
#'
#' @param x
#' A float vector/matrix.
#' @param norm
#' "O"-ne or "I"-nfinity norm.
#' @param triangular
#' Should only the lower triangle be used?
#' @param ...
#' Additional arguments.
#'
#' @return
#' A single float.
#'
#' @examples
#' library(float)
#'
#' s = flrunif(10, 3)
#' rcond(s)
#'
#' @useDynLib float R_rcond_spm
#' @name rcond
#' @rdname rcond
NULL

rcond_float32 = function(x, norm=c("O","I","1"), triangular=FALSE, ...)
{
  if (isavec(x))
    stop("is.matrix(x) is not TRUE")

  if (missing(norm))
    norm = "O"

  m = nrow(x)
  n = ncol(x)

  if (m > n)
    rcond_float32(qr.R(qr(x)), norm=norm, ...)
  else if (m < n)
    rcond_float32(qr.R(qr(t(x))), norm=norm, ...)
  else
  {
    ret = .Call(R_rcond_spm, DATA(x), norm, triangular)
    float32(ret)
  }
}

#' @rdname rcond
#' @export
setMethod("rcond", signature(x="float32", norm="ANY"), rcond_float32)

### TODO kappa


GrayEncode <- function(binary) {
	gray <- substr(binary,1,1)
	repeat {
	if  (substr(binary,1,1) != substr(binary,2,2)) gray <- paste(gray,"1",sep="")
	else gray <- paste(gray,"0",sep="")
	binary <- substr(binary,2,nchar(binary))
	if (nchar(binary) <=1) {
		break
		}
	}
return (gray)
}
GrayDecode <- function(gray) {
	binary <- substr(gray,1,1)
	repeat {
	if  (substr(binary,nchar(binary),nchar(binary)) != substr(gray,2,2)) binary <- paste(binary ,"1",sep="")
	else binary <- paste(binary ,"0",sep="")
	gray <- substr(gray,2,nchar(gray))

	if (nchar(gray) <=1) {
		break
		}
	}
return (binary)
}


library(tm)
data(crude)

tdm <- TermDocumentMatrix(
    crude,
    control = list(
        weight = function(x) weightTfIdf(x, normalize = TRUE),
        stopwords = TRUE
    )
)
inspect(tdm)