#' Unit Testing script for NMF package: NMF algorithms.
#'
#' @author Renaud Gaujoux
#' @creation 22 April 2009

library(rngtools)

.TestSeed <- 123456

.testData <- function(n=20, r=3, m=10, ...){
	syntheticNMF(n, r, m, ...)
}

checkNMFPlot <- function(V, res, prefix=''){

	if( isCHECK() ) return()

	# check heatmaps of the target matrix, the metaprofiles and the metagenes
	checkPlot( aheatmap(V), paste(prefix, ': Target'))
	checkPlot( coefmap(res), paste(prefix, ': Metaprofiles'))
	checkPlot( basismap(res), paste(prefix, ': Metagenes'))
}

#' Tests an algorithm on all data: synthetic, Golub, Cell-type
checkData <- function(meth, ...){

	message("\n###############\n#", meth, "\n###############")
	# On synthetic data

		#1. with noise
		set.seed(.TestSeed)
		r <- 3; V <- .testData(r=r)
		n <- nrow(V); m <- ncol(V);

		res <- nmf(V, r, meth, ..., rng=1234)

		# check the consistency of the result
		checkTrue( validObject(res), 'Returned object is valid')
		checkEquals(nrow(res), n, 'W has correct number of rows', checkNames=FALSE)
		checkEquals(nbasis(res), r, 'Result has correct rank', checkNames=FALSE)
		checkEquals(ncol(res), m, 'H has correct number of columns', checkNames=FALSE)
		checkEquals(algorithm(res), meth, "Algorithm's name is correctly set", checkNames=FALSE)

		wr <- nmfWrapper(meth)
		checkTrue( isNMFfit(resWrapper <- wr(V, r, ..., rng=1234)), 'Wrapper call works')
		checkTrue( nmf.equal(res, resWrapper), 'Wrapper call gives identical result')

		# check heatmaps
		checkNMFPlot(V, res, 'Synthetic [noise]')

		#2. with noise + offset
		n.offset <- 15
		o <- c(rep(1, n.offset), rep(0, n-n.offset))
		set.seed(.TestSeed)
		V <- syntheticNMF(n, r, m, offset=o, noise=TRUE)
		res <- nmf(V, r, meth, ...)
		# check heatmaps
		checkNMFPlot(V, res, 'Synthetic [noise + offset]')

	# On Golub data
		data(esGolub)
		eset <- esGolub[1:50,]
		# check the heatmap of the target expression matrix
		set.seed(.TestSeed)
		res <- nmf(eset, r, meth, ...)
		# check heatmaps
		checkNMFPlot(exprs(eset), res, 'Golub')

	return()
	# On Cell-type data
		data(CellType)
		eset <- esCellType[1:100,]
		V <- exp(exprs(eset))
		# check the heatmap of the target expression matrix
		set.seed(.TestSeed)
		res <- nmf(V, r, meth, ...)
		# check heatmaps
		checkNMFPlot(V, res, 'Cell-type')

}

#' Tests Brunet algorithm
test.brunet <- function(){
	checkData('brunet')
}

#' Tests KL algorithm
test.KL <- function(){
	checkData('KL')
}

#' Tests Lee algorithm
test.lee <- function(){
	checkData('lee')
}

#' Tests Frobenius algorithm
test.frobenius <- function(){
	checkData('Frobenius')
}

#' Test NMF with offset
test.offset <- function(){
	checkData('offset')
}

#' Test Nonsmooth NMF
test.ns <- function(){
	checkData('nsNMF', theta=0.6)
}

#' Test Sparse NMF (i.e. NNLS)
test.snmf <- function(){
	checkData('snmf/r')#, version='R')
	checkData('snmf/l')#, version='L')

	# check errors due to parameter checks
	set.seed(.TestSeed)
	V <- .testData()
	# beta
	checkException(nmf(V, 3, 'snmf/r', beta=0), 'beta: 0 is not a valid value')
	checkException(nmf(V, 3, 'snmf/r', beta=-1), 'beta: <0 is not a valid value')
	# bi_conv
	checkException(nmf(V, 3, 'snmf/r', bi_conv=-1), 'bi_conv: 1-length vector is not a valid value')
	checkException(nmf(V, 3, 'snmf/r', bi_conv=c(-1, 10, 3)), 'bi_conv: > 2-length vector is not a valid value')
	checkException(nmf(V, 3, 'snmf/r', bi_conv=c(-1, 10)), 'wminchange: <0 is not a valid value')
	checkException(nmf(V, 3, 'snmf/r', bi_conv=c(0, -1)), 'iconv: <0 is not a valid value')
	# eps_conv
	checkException(nmf(V, 3, 'snmf/r', eps_conv=0), 'eps_conv: 0 is not a valid value')
	checkException(nmf(V, 3, 'snmf/r', eps_conv=-1), 'eps_conv: <0 is not a valid value')

	# check passage of parameters
	# eps_conv
	res <- nmf(V, 3, 'snmf/r', eps_conv=1)
	checkEquals(res@parameters$eps_conv, 1, 'eps_conv: argument is passed to algorithm')
	# eta
	res <- nmf(V, 3, 'snmf/r', eta=1)
	checkEquals(res@parameters$eta, 1, 'eta: argument is passed to algorithm')
	# beta
	res <- nmf(V, 3, 'snmf/r', beta=0.05)
	checkEquals(res@parameters$beta, 0.05, 'beta: argument is passed to algorithm')
	# bi_conv
	res <- nmf(V, 3, 'snmf/r', bi_conv=c(1, 10))
	checkEquals(res@parameters$bi_conv, c(1, 10), 'bi_conv: argument is passed to algorithm')
}

#' Test Local NMF
test.lnmf <- function(){
	DEACTIVATED("Algorithm 'lnmf' is not fully working.")
	checkData('lnmf')
}

##' Tests multiple runs of NMF, using Brunet algorithm Golub data.
#atest.zzz.runs <- function(){
#
#	# define the number of runs
#	N <- 3
#	r <- 3
#
#	# load data
#	data(esGolub)
#	eset <- esGolub[1:50, ]
#
#	# run nmf N times
#	set.seed(.TestSeed)
#	res <- nmf(eset, r, 'brunet', nrun=N)
#
#	# check the consensus matrix
#	checkPlot( basicHM(connectivity(res)), 'Consensus matrix')
#
#}

#' Unit test for identical results if NMF algorithms
check.algos <- function(algo1, algo2, identical=FALSE){

	r <- 3
	data(esGolub)
	eset <- esGolub[1:50,]
	res1 <- nmf(eset, r, algo1, seed=.TestSeed)
	res2 <- nmf(eset, r, algo2, seed=.TestSeed)
	checkTrue( nmf.equal(res2, res2, identical=identical)
			, paste("Results are the same for '", algo1, "' and '", algo2, "'", sep=''))

}

#' Unit test for C and R versions of algorithms
check.cversion <- function(algo){

	check.algos(paste('.R#', algo, sep=''), algo)

}

#' Unit test for C and R versions of the algorithm: Brunet
test.cversions.brunet <- function(){

	check.cversion('brunet')

}

#' Unit test for C and R versions of the algorithm: Lee
test.cversions.lee <- function(){

	check.cversion('lee')

}

#' Unit test for C and R versions of the algorithm: nsNMF
test.cversions.ns <- function(){

	check.cversion('ns')

}

#' Unit test for C and R versions of the algorithm: Offset
test.cversions.offset <- function(){

	check.cversion('offset')

}

#' Unit test for C and R versions of the algorithm: Lee
test.cversions.lnmf <- function(){

	DEACTIVATED("Algorithm 'lnmf' is not fully working.")
	check.cversion('lnmf')

}

#' Unit test for the port of `brunet`
test.port_brunet <- function(){

	# load RcppOctave if possible
	if( !require(RcppOctave) ){
		DEACTIVATED("Package RcppOctave not available.")
	}

	# source
	o_source(file.path(packagePath('m-files', package='NMF'), 'brunet.m'))

	# define input data
	setRNG('default', 'default')
	set.seed(1234)
	x <- rmatrix(100,20)
	x0 <- rnmf(3, x)

	# run MATLAB code: brunet(v,r,verbose, w, h)
	o <- .CallOctave('brunet', x, 3, FALSE, basis(x0), coef(x0))
	ofit <- nmfModel(o$W, o$H)
	checkTrue( !nmf.equal(ofit, x0), "MATLAB version returned something different than the seed model")
	o2 <- .CallOctave('brunet', x, 3, FALSE, basis(x0), coef(x0))
	ofit2 <- nmfModel(o2$W, o2$H)
	checkTrue( nmf.equal(ofit, ofit2), "MATLAB version really uses the seed model")
    o_rm("brunet")

    # do not use option maxIter here.
	# run R port
	tol <- 10^-14
    res <- nmf(x, 3, '.R#brunet', seed=x0, maxIter = 2000L)
    checkEquals(niter(res), o$niter, "Pure R and MATLAB use same number of iterations")
	checkTrue(nmf.equal(ofit, res, tolerance=tol)
			, paste("Pure R port and MATLAB results are identical at tolerance ", tol))

	# C version with copy
    res <- nmf(x, 3, 'brunet', seed=x0, copy=TRUE, maxIter = 2000L)
    checkEquals(niter(res), o$niter, "C version without copy and MATLAB use same number of iterations")
	checkTrue(isTRUE(nmf.equal(ofit, res, tolerance=tol))
			, paste("C version with copy and MATLAB results are identical at tolerance ", tol))
	# C version without copy
    res <- nmf(x, 3, 'brunet', seed=x0, copy=FALSE, maxIter = 2000L)
    checkEquals(niter(res), o$niter, "C version without copy and MATLAB use same number of iterations")
	checkTrue(isTRUE(nmf.equal(ofit, res, tolerance=tol))
			, paste("C version without copy and MATLAB results are identical at tolerance ", tol))

	# check NMFStrategyOctave
	check.algos('brunet', '.M#brunet', identical=TRUE)

}


library(tidyr)
library(data.table)

aggregate_contact_rates_period = function(countries, path_to_file_contact, age_bands, path_to_file_population){
  ## PARTS OF THIS CODE IS TAKEN FROM "Contact-patterns" repository BELONGING TO kassteele
  ## https://github.com/kassteele/Contact-patterns

  pop.data = read.csv(path_to_file_population)

  # create map to country abbrevation to read inputs
  country.abb = data.table(country = c("Belgium", "Germany", "Finland", "United_Kingdom", "Italy", "Luxembourg", "Netherlands", "Poland"),
                           abb = c("BE", "DE", "FI", "GB", "IT", "LU", "NL", "PL"))
  # Get ages and number of age classes
  age <- 0:99
  n.age <- length(age)

  # Define age cateogries
  age.cat <- sapply(strsplit(gsub("\\[|\\]|\\(|\\+", "", age_bands$age), "-"), as.numeric)
  if (is.na(age.cat[[length(age.cat)]][2])) age.cat[[length(age.cat)]][2] <- 99
  age.cat <- matrix(unlist(age.cat), ncol = 2, byrow = TRUE)
  age.cat <- cut(age, breaks = c(age.cat[,1],100), include.highest = FALSE, right = FALSE)

  contact.tab.agg = list()

  for(Country in countries){
    pop.data.c = subset(pop.data, country == Country & age %in% 0:99)

    # Reshape pop.data in wide format.
    pop.data.wide <- cbind(
      data.frame(age = age),
      matrix(pop.data.c$pop, nrow = n.age, ncol = 1, dimnames = list(NULL, c("pop"))))
    pop.data.wide <- cbind(pop.data.wide, age.cat = age.cat)

    contact.tab.agg[[Country]] = list()

    for(period in c("weekday", "weekend")){

      load(path_to_file_contact(country.abb[which(country.abb$country == Country), ]$abb, period))

      contact.tab.c.p = polymod.tab

      # Create a dataframe contact.data with n.age^2 rows.
      contact.data <- cbind(
        expand.grid(part.age = age, cont.age = age),
        matrix(contact.tab.c.p$m, nrow = n.age^2, ncol = 1, dimnames = list(NULL, c("m"))))

      # Add age categories to contact.data and pop.data
      contact.data <- cbind(contact.data, expand.grid(part.age.cat = age.cat, cont.age.cat = age.cat))

      # Aggregate population numbers
      pop.data.agg <- aggregate(cbind(pop) ~ age.cat, FUN = sum, data = pop.data.wide)

      # Aggegrate contact intensities over ages
      record.id.part <- match(x = contact.data$part.age, table = pop.data.wide$age)
      record.id.part.agg <- match(x = contact.data$part.age.cat, table = pop.data.agg$age.cat)
      contact.data.agg <- within(contact.data, {
        m   <- pop.data.wide[record.id.part, "pop" ]*m  /pop.data.agg[record.id.part.agg, "pop" ]
      })
      contact.data.agg <- aggregate(cbind(m) ~ part.age.cat + cont.age.cat, FUN = sum, data = contact.data.agg)

      # Reorder columns
      contact.data.agg <- contact.data.agg[, c("part.age.cat", "cont.age.cat", "m")]

      # rename the age
      contact.data.agg = dplyr::rename(contact.data.agg, part.age = part.age.cat, cont.age = cont.age.cat)

      contact.tab.agg[[Country]][[period]] = contact.data.agg
    }
  }

 return(contact.tab.agg)
}

map_contact_tab_to_matrix_period = function(countries, contact_tab){
  contact_tab_matrix = list()

  for(Country in countries){

    contact_tab_matrix[[Country]] = list()

      for(period in c("weekend", "weekday")){

      contact_tab_matrix.c.p <- pivot_wider(contact_tab[[Country]][[period]], id_cols= part.age, names_from = cont.age, values_from = m)
      stopifnot( all( colnames(contact_tab_matrix.c.p)[-1] == contact_tab_matrix.c.p$part.age ) )
      contact_tab_matrix[[Country]][[period]] <- unname(as.matrix(contact_tab_matrix.c.p[,-1]))
    }
  }
  return(contact_tab_matrix)
}

aggregate_contact_rates = function(countries, contact_tab, age_bands, path_to_file_population){

  pop.data = read.csv(path_to_file_population)

  # Get ages and number of age classes
  age <- 0:99
  n.age <- length(age)

  # Define age cateogries
  #age.cat <- cut(age, breaks = seq(0, 100, cntct_by), include.highest = FALSE, right = FALSE)
  age.cat <- sapply(strsplit(gsub("\\[|\\]|\\(|\\+", "", age_bands$age), "-"), as.numeric)
  if (is.na(age.cat[[length(age.cat)]][2])) age.cat[[length(age.cat)]][2] <- 99
  age.cat <- matrix(unlist(age.cat), ncol = 2, byrow = TRUE)
  age.cat <- cut(age, breaks = c(age.cat[,1],100), include.highest = FALSE, right = FALSE)

  contact.tab.agg = list()

  for(Country in countries){
    pop.data.c = subset(pop.data, country == Country & age %in% 0:99)

    # Reshape pop.data in wide format.
    pop.data.wide <- cbind(
      data.frame(age = age),
      matrix(pop.data.c$pop, nrow = n.age, ncol = 1, dimnames = list(NULL, c("pop"))))
    pop.data.wide <- cbind(pop.data.wide, age.cat = age.cat)

    contact.tab.c = contact_tab[[Country]]

    # Create a dataframe contact.data with n.age^2 rows.
    contact.data <- cbind(
      expand.grid(part.age = age, cont.age = age),
      matrix(contact.tab.c$m, nrow = n.age^2, ncol = 1, dimnames = list(NULL, c("m"))))

    # Add age categories to contact.data and pop.data
    contact.data <- cbind(contact.data, expand.grid(part.age.cat = age.cat, cont.age.cat = age.cat))

    # Aggregate population numbers
    pop.data.agg <- aggregate(cbind(pop) ~ age.cat, FUN = sum, data = pop.data.wide)

    # Aggegrate contact intensities over ages
    record.id.part <- match(x = contact.data$part.age, table = pop.data.wide$age)
    record.id.part.agg <- match(x = contact.data$part.age.cat, table = pop.data.agg$age.cat)
    contact.data.agg <- within(contact.data, {
      m   <- pop.data.wide[record.id.part, "pop" ]*m  /pop.data.agg[record.id.part.agg, "pop" ]
    })
    contact.data.agg <- aggregate(cbind(m) ~ part.age.cat + cont.age.cat, FUN = sum, data = contact.data.agg)

    # Reorder columns
    contact.data.agg <- contact.data.agg[, c("part.age.cat", "cont.age.cat", "m")]

    # rename the age
    contact.data.agg = dplyr::rename(contact.data.agg, part.age = part.age.cat, cont.age = cont.age.cat)

    contact.tab.agg[[Country]] = contact.data.agg
  }

  return(contact.tab.agg)
}

map_contact_tab_to_matrix = function(countries, contact_tab){
  contact_tab_matrix = list()

  for(Country in countries){
    contact_tab_matrix.c <- pivot_wider(contact_tab[[Country]], id_cols= part.age, names_from = cont.age, values_from = m)
    stopifnot( all( colnames(contact_tab_matrix.c)[-1] == contact_tab_matrix.c$part.age ) )
    contact_tab_matrix[[Country]] <- unname(as.matrix(contact_tab_matrix.c[,-1]))
  }
  return(contact_tab_matrix)
}


#对单个内容进行画图分析，尝试记录单个内容的pdf图片格式
#文件名：distance_stable , 电压差与三种液体之间随流量、极间距离、针头直径变化的影响

######################读取文件模块###################
#setwd("D:/data")
library(xlsx)

#读取distance~voltage的数据
de_h<-read.xlsx("voltage.xls",sheetName="ethanol_d", header=TRUE)
da_h<-read.xlsx("voltage.xls",sheetName="acetone_d", header=TRUE)
di_h<-read.xlsx("voltage.xls",sheetName="iso_d", header=TRUE)

#保存pdf
pdf("distance_3liquids_stable.pdf")
#画图-乙醇

plot(de_h$distance, de_h$stable,  col=0, xaxs="i",
     xlim=c(0, 4.2), ylim=c(0.6, 1.3),
xlab="Distance (mm)",cex.lab=1.1, mgp=c(1, 0, 0),
tck=0.02,
ylab=expression(V["stable"](kv)))

title(main="Voltage range changes with distance",line=0.5,cex.main=1.1)

model_esv <- loess(de_h$stable ~ de_h$distance)
fit <- fitted(model_esv)
ord <- order(de_h$distance)

lines(de_h$distance[ord], fit[ord], type="b", pch=6, col="red", lwd=2.5, lty=2)

#画图-丙酮
#points(da_h$distance, da_h$BV,  pch=23, col="blue")

model_asv <- loess(da_h$stable ~ da_h$distance)
fit <- fitted(model_asv)
ord <- order(da_h$distance)

lines(da_h$distance[ord], fit[ord], type="b", col="blue", pch=23, lwd=2.5, lty=2) # 丙酮的拟合曲线

#画图-异丙醇
#points(di_h$distance, di_h$BV,  pch=23, col="green")

model_isv <- loess(di_h$stable ~ di_h$distance)
fit <- fitted(model_isv)
ord <- order(di_h$distance)

lines(di_h$distance[ord], fit[ord], type="b", col="darkgreen", pch=24, lwd=2.5, lty=2) # 异丙醇的拟合曲线

#图例标注
legend("bottomright",bty="n", c("Ethanol", "Acetone", "Isoproply"), inset=.1,
       pch=c(6, 23, 24), col=c("red", "blue", "darkgreen"),
       lty=2, lwd=2.5, cex=1)

dev.off()


#
# R-Code zu NOT-Statistik 2. Auflage
#

# Stand 30.01.2021

## Kapitel 3 ##
#

#++++++++++++++++++++++++++++++++++++++++++++++++#
# S. 51: Daten in R einlesen
# Vorbereitung: Daten-Datei "PLZ_0.CSV" lokal speichern
PLZ.0 = read.csv2(file.choose(), stringsAsFactors = TRUE)
# erstellt Daten-Container "PLZ.0"
# read.csv2() liest eine csv-Datei mit Komma als Dezimaltrenner in "PLZ.0" ein
# file.choose() öffnet den Explorer zur Dateiauswahl, ausgewählt wird "PLZ_0.CSV"
# stringsAsFactors = TRUE importiert Buchstaben/Zeichenketten als Faktoren

PLZ.0$Beginn=as.Date(PLZ.0$Beginn, "%d.%m.%Y")
PLZ.0$Ende=as.Date(PLZ.0$Ende, "%d.%m.%Y")
# PLZ.0$[Spaltenname] wählt Spalte aus
# Datumsformatierung für Spalten "Beginn" und "Ende"

str(PLZ.0) # zeigt eine Übersicht der PLZ.0-Daten und Formate an

attach(PLZ.0) # PLZ.0-Merkmale so direkt über Spaltennamen auswählbar

#++++++++++++++++++++++++++++++++++++++++++++++++#
# S. 51: Balkendiagramm
# plot() zeichnet Balkendiagramm für attributive Merkmale
plot(Lieferant)
plot(Kunde)
plot(Methode)
plot(Review)
plot(Komplexität)

#++++++++++++++++++++++++++++++++++++++++++++++++#
# S. 51: Einzelwertdiagramme
# stripchart() zeichnet Einzelwertdiagramm
stripchart(PL, vertical=TRUE, method="stack", pch=20, main="PL")
# vertical=TRUE: Punkte werden vertikal eingezeichnet
# "stack": gleiche Werte stapeln
# pch: point character, 20 ist ein ausgefüllter Kreis
# main: setzt Titel über die Grafik
stripchart(PMa, vertical=TRUE, method="stack", pch=20, main="PMa")
stripchart(Abteilungen, vertical=TRUE, method="stack", pch=20, main="Abteilungen")
stripchart(Laufzeit, vertical=TRUE, method="stack", pch=20, main="Laufzeit")

#++++++++++++++++++++++++++++++++++++++++++++++++#
# S. 52: Zeitreihendiagramme für 1 Merkmal
# plot() zeichnet Zeitreihendiagramm für variable Merkmale
plot(PL, type="b")	# type="b": both, d. h. Linien und Punkte zeichnen
plot(PMa, type="b")
plot(Abteilungen, type="b")
plot(Laufzeit, type="b")

#++++++++++++++++++++++++++++++++++++++++++++++++#
# S. 52: Zeitreihendiagramm gemeinsam für Beginn und Ende
plot(Beginn, type="b", pch=20, xlab="Index")
lines(Ende, type="b", col="blue", pch=20)
# Hinzufügen der Linien und Punkte für 'Ende'
# col: color, Farbe für Linie und Punkte

#++++++++++++++++++++++++++++++++++++++++++++++++#
# S. 56: Zeilennummern für Einträge finden
# which() liefert Zeilennummern mit vorgegebenen Kriterien
which(Lieferant == "Ja")
which(Kunde == "nein ")
which(Review == "eventuell" | Review == "vielleicht")
# | ist das Zeichen für ODER
which(PL > 50)
which(Laufzeit < 0)

#++++++++++++++++++++++++++++++++++++++++++++++++#
# S. 57: Einlesen der überarbeiteten Daten
setwd("~/Arbeit/Buch/SPM/R")

detach(PLZ.0)
# Die Merkmalsnamen im R-Speicher müssen eindeutig sein. Da die Spaltennamen in "PLZ_0.CSV" und "PLZ_1.CSV"
# identisch sind, wird zuerst die alte Daten-Datei aus dem direkten R-Speicher entfernt. Sie sind mit der
# Angabe "PLZ.0$[Spaltenname]" weiter verfügbar.

# Vorbereitung: Daten-Datei "PLZ_1.CSV" lokal speichern
PLZ.1 = read.csv2(file.choose(), stringsAsFactors = TRUE)
# erstellt Daten-Container "PLZ.1"
# eingelesen in "PLZ.1" wird jetzt die Datei "PLZ_1.CSV"

# Formatierung des Datums
PLZ.1$Beginn=as.Date(PLZ.1$Beginn, "%d.%m.%Y")
PLZ.1$Ende=as.Date(PLZ.1$Ende, "%d.%m.%Y")

str(PLZ.1) # Übersicht Einträge in "PLZ.1"
attach(PLZ.1) # Daten-Container "PLZ.1" im direkten R-Speicher verfügbar machen

#++++++++++++++++++++++++++++++++++++++++++++++++#
# S. 57: Erstellen der Grafiken mit PLZ.1
# Balkendiagramme
plot(Lieferant)
plot(Kunde)
plot(Review)

# Einzelwertdiagramme
stripchart(PL, vertical=TRUE, method="stack", pch=20, main="PL")
stripchart(Laufzeit, vertical=TRUE, method="stack", pch=20, main="Laufzeit")

# Zeitreihendiagramme
plot(PL, type="b")
plot(Laufzeit, type="b")

## Kapitel 4 ##
#
# Grafiken

#++++++++++++++++++++++++++++++++++++++++++++++++#
# S. 67: Boxplots
# Daten PLZ_1.CSV sind eingelesen und mit attach(PLZ.1) verfügbar gemacht

boxplot(Laufzeit ~ Lieferant, pch=8, col="lightgrey", lty=1)
# erstellt Boxplot für Laufzeit nach Lieferant
# pch=8: Extremwerte werden als Stern angezeigt
# col="lightgrey": Kästen werden hellgrau ausgefüllt
# lty=1: Linien werden durchgezogen gezeichnet
boxplot(Laufzeit ~ Kunde, pch=8, col="lightgrey", lty=1)
boxplot(Laufzeit ~ Methode, pch=8, col="lightgrey", lty=1)
boxplot(Laufzeit ~ Review, pch=8, col="lightgrey", lty=1)
boxplot(Laufzeit ~ Komplexität, pch=8, col="lightgrey", lty=1)

#++++++++++++++++++++++++++++++++++++++++++++++++#
# S. 69: Haupteffekte-Diagramm
# Definieren einer Haupteffekte-Diagramm-Funktion: HEdiagramm
HEdiagramm = function(x,y){
  mw = aggregate(y ~ x, data=PLZ.1, FUN=mean)
  # erstellt Variable mw
  # speichert die Mittelwerte (mw) von y je Stufe von x aus den Daten PLZ.1 über die Funktion (FUN) mean darin
  plot(mw, lty="blank", xlab=deparse(substitute(x)), ylab=deparse(substitute(y)))
  # zeichnet ein leeres Diagramm mit Achsen und Achsen-Beschriftung
  lines(mw) # fügt Verbindungslinie der Mittelwerte hinzu
  points(mw, pch=19) # zeichnet Punkte für die Mittelwerte ein
}
HEdiagramm(Lieferant,Laufzeit)
HEdiagramm(Kunde,Laufzeit)
HEdiagramm(Methode,Laufzeit)
HEdiagramm(Review,Laufzeit)
HEdiagramm(Komplexität,Laufzeit)

#++++++++++++++++++++++++++++++++++++++++++++++++#
# S. 72: Streudiagramm-Matrix (im Buch: Wechselwirkungs-Diagramm)
require(lattice)
# für die Streudiagramm-Matrix muss das Package "lattice" installiert sein
# Pakete in R installieren (Internetverbindung notwendig!):
# Pakete > Installiere Pakete > OK > Paketnamen in der Liste finden > OK

PLZ.1.variabel = subset(PLZ.1, select=c(PL,PMa,Abteilungen,Laufzeit))
# subset() erstellt Teilmenge aus PLZ.1, die alle vier variablen Merkmale PL, PMa, Abteilungen und Laufzeit enthält
splom(~PLZ.1.variabel)

#++++++++++++++++++++++++++++++++++++++++++++++++#
# S. 76: Wechselwirkungs-Diagramm
interaction.plot(Lieferant,Kunde,Laufzeit, type="b", col=1:nlevels(Kunde))
# interaction.plot ist Funktion für Wechselwirkungs-Diagramme
# hier: Lieferant auf x-Achse, Kunde für unterschiedliche Linien
# type="b": Linien und Punkte ("both") zeichnen
# col=1:nlevels(Kunde): Farben ("colors") der Linien und Punkte
interaction.plot(Lieferant,Methode,Laufzeit, type="b", col=1:nlevels(Methode))
interaction.plot(Lieferant,Review,Laufzeit, type="b", col=1:nlevels(Review))
interaction.plot(Lieferant,Komplexität,Laufzeit, type="b", col=1:nlevels(Komplexität))
interaction.plot(Kunde,Methode,Laufzeit, type="b", col=1:nlevels(Methode))
interaction.plot(Kunde,Review,Laufzeit, type="b", col=1:nlevels(Review))
interaction.plot(Kunde,Komplexität,Laufzeit, type="b", col=1:nlevels(Komplexität))
interaction.plot(Methode,Review,Laufzeit, type="b", col=1:nlevels(Review))
interaction.plot(Methode,Komplexität,Laufzeit, type="b", col=1:nlevels(Komplexität))
interaction.plot(Review,Komplexität,Laufzeit, type="b", col=1:nlevels(Komplexität))

#++++++++++++++++++++++++++++++++++++++++++++++++#
# S. 81: 3D-Streudiagramme
cloud(Laufzeit ~ PL + PMa, scales = list(arrows=FALSE))
# erstellt ein 3D-Streudiagramm (Punktewolke / cloud)
# für Laufzeit (Z-Achse) mit PL (Y-Achse)  und PMa (X-Achse)
# scales = list(arrows=FALSE): Achsenbeschriftung (Skala) mit Zahlen statt Pfeilen
cloud(Laufzeit ~ PL + Abteilungen, scales = list(arrows=FALSE))
cloud(Laufzeit ~ PL + PMa, scales = list(arrows=FALSE))

#++++++++++++++++++++++++++++++++++++++++++++++++#
# S. 84: Matrixplot mit attributiven Merkmalen
PLZ.1.variabel = subset(PLZ.1, select=c(PL,PMa,Abteilungen,Laufzeit))
#  subset() erstellt Teilmenge aus PLZ.1, die alle variablen Merkmale enthält

symbole = trellis.par.get("superpose.symbol")
# Eigenschaften von Gruppierungs-Symbolen in "symbole" gespeichert

splom(~PLZ.1.variabel, # Streudiagramm-Matrix für alle variablen Merkmale
	groups=Komplexität, # unterschieden nach Komplexitäts-Stufen
	key=list(columns=3,
		points=list(pch=symbole$pch[1:3], col=symbole$col[1:3]),
		text=list(levels(Komplexität)))
	# key definiert die Legende (Liste mit Vorgaben):
	# columns=3: Anzahl Legenden-Spalten über der Grafik 3
	# points=... : Vorgabe der Symbole und Farben
	# text=... : Für jedes Legenden-Symbol wird die Bezeichnung/Level von Komplexität eingefügt
	)

## Kapitel 5 ##
#
# Erstes statistisches Prozess-Modell

#++++++++++++++++++++++++++++++++++++++++++++++++#
# S. 98: Erstes SPM
# Daten PLZ_1.CSV sind eingelesen und mit attach(PLZ.1) verfügbar gemacht

require(car)
# für die hier verwendeten Kontraste und Varianzanalyse (ANOVA) wird das Paket car benötigt

lm.1 = lm(Laufzeit ~ PL + PMa + Abteilungen + Lieferant + Kunde + Methode + Review + Komplexität
          + PL:PMa + PL:Abteilungen + PL:Lieferant + PL:Kunde + PL:Methode + PL:Review + PL:Komplexität
          + PMa:Abteilungen + PMa:Lieferant + PMa:Kunde + PMa:Methode + PMa:Review + PMa:Komplexität
          + Abteilungen:Lieferant + Abteilungen:Kunde + Abteilungen:Methode + Abteilungen:Review + Abteilungen:Komplexität
          + Lieferant:Kunde + Lieferant:Methode + Lieferant:Review + Lieferant:Komplexität
          + Kunde:Methode + Kunde:Review + Kunde:Komplexität
          + Methode:Review + Methode:Komplexität
          + Review:Komplexität
          + I(PL^2) + I(PMa^2),
          contrasts=list(Lieferant=contr.Sum,Kunde=contr.Sum,Methode=contr.Sum,Review=contr.Sum,Komplexität=contr.Sum),
          data=PLZ.1)
# in Container lm.1 sind die Ergebnisse des ersten SPMs gespeichert
# lm: linear model für Zielgröße Laufzeit (vor der Tilde ~)
# PL:PMa (z. B.) Wechselwirkung, durch ":" angegeben
# I(PL^2) quadratischer Effekt von PL
# contrasts: Art der Effekt-Berechnung von attributiven Merkmalen

Anova(lm.1, type=3)
# gibt eine Varianzanalyse-Tabelle mit dem Berechnungstyp 3 aus

## Kapitel 6 ##
#
# SPM vereinfachen

#++++++++++++++++++++++++++++++++++++++++++++++++#
# S. 103: Auswahl Effekt-Kodierung
getOption("contrasts")
# zeigt die Einstellungen für die Kontraste an:
# erster Eintrag für Faktoren ohne Rangfolge (Voreinstellung: contr.treatment)
# zweiter Eintrag für Faktoren mit Rangfolge (Voreinstellung: contr.poly)

options(contrasts=c("contr.Sum","contr.poly"))
# setzt die Kontraste global für alle Modelle
# contr.Sum: Effekt-Kodierung für attributive Merkmale ohne Rangfolge der Stufen
# contr.poly: polynomiale Kodierung für attributive Merkmale mit Rangfolge der Stufen
getOption("contrasts")
# geänderte Kontrast-Einstellung: "contr.Sum" und "contr.poly"

#++++++++++++++++++++++++++++++++++++++++++++++++#
# S. 120: Unwichtige Einflüsse ausschließen (1/2)
# Daten PLZ_1.CSV sind eingelesen
# Das SPM lm.1 ist berechnet

lm.1.step = step(lm.1, direction="both")
# step: schrittweise Auswahl wichtiger Einflüsse über AIC
# direction="both": Ausschluss und Hinzunahme in der Auswahl-Strategie

require(car) # Paket car laden

Anova(lm.1.step, type=3)

#++++++++++++++++++++++++++++++++++++++++++++++++#
# S. 121: Unwichtige Einflüsse ausschließen (2/2)
# Daten PLZ_1.CSV sind eingelesen

lm.2 = lm(Laufzeit ~ PL + PMa + Abteilungen + Lieferant + Kunde + Methode + Review + Komplexität
          + I(PMa^2)
          + PL:PMa
          + Abteilungen:Methode
          + Lieferant:Kunde
          + Kunde:Komplexität
          + Methode:Review,
          data = PLZ.1)

Anova(lm.2, type=3)

## Kapitel 7 ##
#
# Modell-Qualität prüfen

#++++++++++++++++++++++++++++++++++++++++++++++++#
# S. 133: Modell-Qualitäts-Kennzahlen R², R²(prog) und S
# lm.2 wurde berechnet

SST = sum((Laufzeit-mean(Laufzeit, na.rm=TRUE))^2)
# berechnet SST und speichert Wert in "SST"
SSE = sum(resid(lm.2)^2)
# berechnet SSE und speichert Wert in "SSE"
R2 = 1-SSE/SST # berechnet R² und speichert Wert in "R2"
R2 # zeigt Wert von "R2" an, hier: 0.8744451 = 87,44%

PRESS = sum((resid(lm.2)/(1-hatvalues(lm.2)))^2)
# berechnet PRESS und speichert Wert in "PRESS"
PRESS # zeigt Wert von "PRESS" an
R2.prog = 1-PRESS/SST # berechnet R²_prog und speichert Wert in "R2.prog"
R2.prog # zeigt Wert von "R2.prog" an, hier: 0.8366248 = 83,66%

S.spm = sqrt(SSE/df.residual(lm.2))
# berechnet Modell-Standardabweichung S und speichert Wert in "S.spm"
# df.residual ermittelt die Freiheitsgrade der Residuen, hier: n-k=115
S.spm # zeigt Wert von "S.spm" an, hier: 8.533396 = 8,53 Tage

#++++++++++++++++++++++++++++++++++++++++++++++++#
# S. 141: Residuendiagramme: Wahrscheinlichkeitsnetze
# lm.2 wurde berechnet

qqnorm(residuals(lm.2), xlab="Normalverteilungs-Quantile", ylab="Residuen",
	main="Wahrscheinlichkeitsnetz", pch=20)
qqline(residuals(lm.2), col="blue")
# qqnorm zeichnet Wahrscheinlichkeitsnetz für Normalverteilung
# residuals liefert Residuen
# xlab, ylab, main: Beschriftung x-Achse, y-Achse und Titel
# qqline zeichnet Ideallinie (hier: blau)

qqnorm(rstandard(lm.2), xlab="Normalverteilungs-Quantile", ylab="standardisierte Residuen",
	main="W.-Netz", pch=20)
qqline(rstandard(lm.2), col="blue")
# rstandard liefert standardisierte Residuen

qqnorm(rstudent(lm.2), xlab="Normalverteilungs-Quantile", ylab="studentisierte Residuen",
	main="W.-Netz", pch=20)
qqline(rstudent(lm.2), col="blue")
# rstudent liefert studentisierte Residuen

#++++++++++++++++++++++++++++++++++++++++++++++++#
# S. 142: Residuendiagramme: Anpassungen vs. Residuen und Beobachtungsnr. vs. Residuen
# lm.2 wurde berechnet

plot(fitted(lm.2), residuals(lm.2), xlab="Angepasste Werte für Laufzeit", ylab="Residuen", main="Angepasste Werte vs. Residuen", pch=20)
abline(h=0, col="blue")
# fitted liefert die angepassten Werte für die Laufzeit
# abline zeichnet eine Referenzlinie ein, h: horizontal

plot(residuals(lm.2), type="b", xlab="Beobachtungsnummer", ylab="Residuen", main="Beobachtungsnummer vs. Residuen", pch=20)
abline(h=0, col="blue")
# type="b" zeichnet Punkte und Linien ("both")

#++++++++++++++++++++++++++++++++++++++++++++++++#
# S. 143: Residuendiagramme: Auffällige Residuen finden
# lm.2 wurde berechnet

PLZ.1.SPM = cbind(PLZ.1,Fit=fitted(lm.2),Resi=residuals(lm.2))
# cbind: column-bind, hängt Spalten aneinander
# erzeugt Container PLZ.1.SPM mit den Daten PLZ.1 sowie den
# Anpassungen (Fit) und Residuen (Resi)

PLZ.1.SPM[which(residuals(lm.2) < -20),]
# zeigt die Zeile(n) aus PLZ.1.SPM an, für die die Residuen kleiner -20 sind

#++++++++++++++++++++++++++++++++++++++++++++++++#
# S. 158: Modell-Qualitäts-Kennzahlen: Test auf Normalverteilung für Residuen
# lm.2 wurde berechnet

require(nortest)
# für den Anderson-Darling-Test wird das Paket "nortest" benötigt
ad.test(residuals(lm.2))
# berechnet den Anderson-Darling-Test auf Normalverteilung (ad.test) und gibt die Werte aus

## Kapitel 8 ##
#
# Modell-Interpretation und Prognose

#++++++++++++++++++++++++++++++++++++++++++++++++#
# S. 166: Effektediagramme
# lm.2 wurde berechnet

require(effects) # für die Effektdiagramme muss das Paket "effects" installiert sein

# Haupteffekte-Diagramme mit großem E bei Effect
plot(Effect("PL", lm.2, ylim=c(91,156)))
	# ylim gibt Wertebereich der y-Achse an
plot(Effect("PMa", lm.2, ylim=c(91,156)))
plot(Effect("Abteilungen", lm.2, ylim=c(91,156)))
plot(Effect("Lieferant", lm.2, ylim=c(91,156)))
plot(Effect("Kunde", lm.2, ylim=c(91,156)))
plot(Effect("Methode", lm.2, ylim=c(91,156)))
plot(Effect("Review", lm., ylim=c(91,156),2))
plot(Effect("Komplexität", lm.2, ylim=c(91,156)))

# Wechselwirkungsdiagramme mit kleinem e bei effect
plot(effect("PL:PMa", lm.2, ylim=c(72,168)))
plot(effect("Abteilungen:Methode", lm.2, ylim=c(72,168)))
plot(effect("Lieferant:Kunde", lm.2, ylim=c(72,168)))
plot(effect("Kunde:Komplexität", lm.2, ylim=c(72,168)))
plot(effect("Methode:Review", lm.2, ylim=c(72,168)))

#++++++++++++++++++++++++++++++++++++++++++++++++#
# S. 168: Quantile und Auswahl von Projekten
PLZ.1[PL >= quantile(PL, .75)
      & PMa >= quantile(PMa, .75)
      & Laufzeit >= quantile(Laufzeit, .75),]
# [... ,] gibt Auswahlkriterium an
# quantile(x, .75) berechnet 75%-Quantil von x
# Auswahl PL >= Q_75(PL)
# und (&) PMa >= Q_75(PMa)
# und (&) Laufzeit >= Q_75(Laufzeit)

#++++++++++++++++++++++++++++++++++++++++++++++++#
# S. 174: Kontur- und Wirkungsflächendiagramme Laufzeit
# lm.2 wurde berechnet

require(lattice) # Pakte lattice laden

# Gitter-Stützpunkte berechnen
PL.p = seq(min(PL), max(PL), length.out=100)
PMa.p = seq(min(PMa), max(PMa), length.out=100)
# seq() erstellt eine Sequenz von Werten
Abteil.p = c(1,3,6)
punkte = list(PL=PL.p, PMa=PMa.p, Abteilungen=Abteil.p)
# list() erstellt eine Liste
gitter = expand.grid(punkte)
# erstellt das Gitter für die Stützpunkte

gitter.niedrig = cbind(gitter,
	data.frame(Lieferant="nein", Kunde="nein",
	Methode="SiSi", Review="nein",
	Komplexität="niedrig"))
# data.frame() erstellt eine Datenstruktur
gitter.niedrig[, "Prognose"] = c(predict(lm.2, gitter.niedrig))
# mit [,...] wird an den vorhandenen data.frame eine Spalte angefügt
# predict(modell,daten) berechnet Prognosen für "daten", hier für gitter.niedrig

gitter.hoch = cbind(gitter,
	data.frame(Lieferant="ja", Kunde="ja",
	Methode="PDCA", Review="ja",
	Komplexität="hoch"))
gitter.hoch[, "Prognose"] = c(predict(lm.2, gitter.hoch))

# Konturdiagramme
contourplot(Prognose ~ PL*PMa | Abteilungen,
	data=gitter.niedrig, main="Kontur niedrig",
	region=TRUE,cuts=10^3, contour=FALSE,
	col.regions=rainbow(2000))
# contourplot() erstellt das Konturdiagramm
# Prognose ~ PL*PMa | Abteilungen: Höhenlinien aus "Prognose",
# x- und y-Achse PMa und PL,
# unterschiedliche Grafiken je Wert in "Abteilungen"

contourplot(Prognose ~ PL*PMa | Abteilungen,
	data=gitter.hoch, main="Kontur hoch",
	region=TRUE,cuts=10^3, contour=FALSE,
	col.regions=rainbow(2000))

# Wirkungsflächendiagramme
wireframe(Prognose ~ PL*PMa | Abteilungen,
	data=gitter.niedrig, main="Wirkungsfläche niedrig",
	zlab="", colorkey=FALSE, shade=TRUE, drape=TRUE,
	scales=list(arrows=FALSE), light.source = c(0,2,2))
# wireframe() erstellt das Wirkungsflächendiagramm
# Achsen und Grafiken wie in countourplot (s. o.)

wireframe(Prognose ~ PL*PMa | Abteilungen,
	data=gitter.hoch, main="Wirkungsfläche hoch",
	zlab="", colorkey=FALSE, shade=TRUE, drape=TRUE,
	scales=list(arrows=FALSE), light.source = c(0,2,2))

#++++++++++++++++++++++++++++++++++++++++++++++++#
# S. 187: Koeffizienten des vereinfachten SPMs ausgeben
# lm.2 wurde berechnet

round(lm.2$coef,2) # zeigt Koeffizienten von lm.2 an

str(PLZ.1) # zeigt Beschreibung der Daten inkl. Stufen von attributiven Einflussgrößen an

#++++++++++++++++++++++++++++++++++++++++++++++++#
# S. 195 Prognosen für Laufzeit
# lm.2 wurde berechnet

# Einstellwerte vorgeben
Daten.neu = data.frame(Lieferant="ja", Kunde="nein",
	Methode="PDCA", Review="ja",
	Komplexität=c("hoch","mittel","niedrig"),
	PL=10, PMa=5, Abteilungen=2)
# data.frame() erstellt eine Datenstruktur
# Spalten werden aufgefüllt, so dass alle Spalten dieselbe Länge haben

# Prognose berechnen
Prognose=predict(lm.2, Daten.neu)

cbind(Daten.neu,Prognose)
# cbind() verbindet Spaltenweise (column-bind)
# Ergebnis: Anzeige der Einstellwerte und Prognosen

#++++++++++++++++++++++++++++++++++++++++++++++++#
# S. 198: Vertrauens- und Prognosebereiche für Laufzeit
# lm.2 wurde berechnet

# Einstellwerte vorgeben
Daten.neu = data.frame(Lieferant="ja", Kunde="nein",
	Methode="PDCA", Review="ja",
	Komplexität=c("hoch","mittel","niedrig"),
	PL=10, PMa=5, Abteilungen=2)

# Prognose berechnen
Prognose=round(predict(lm.2, Daten.neu),2)
# round() rundet Werte, hier auf 2 Nachkommastellen

# Obere Grenze 98% Vertrauensbereich berechnen
OGW.KI=round(predict(lm.2, Daten.neu, interval="confidence", level=0.98)[,3],2)
# [,3] wählt dritte Spalte aus, die die OGW angibt

# Obere Grenze 98% Prognosebereiche berechnen
OGW.PI=round(predict(lm.2, Daten.neu, interval="prediction", level=0.98)[,3],2)

cbind(Prognose,OGW.KI,OGW.PI)
# cbind() verbindet Spaltenweise (column-bind)
# Ergebnis: Anzeige der Prognosen und obere Streubereichsgrenzen

## Kapitel 9 ##
#
# Prozess-Simulation

#++++++++++++++++++++++++++++++++++++++++++++++++#
# S. 206:  Anzahl Werte für Lieferant
# Daten PLZ_1.CSV sind eingelesen und mit attach(PLZ_1.CSV) verfügbar gemacht
table(Lieferant)

#++++++++++++++++++++++++++++++++++++++++++++++++#
# S. 207: Monte Carlo-Simulation
# lm.2 wurde berechnet

Simu=10^4 # Anzahl Simulationen in "Simu" speichern

simu.attr=function(Merkmal,Simu) {
	sample(rep(levels(Merkmal),rmultinom(1,Simu,prob=table(Merkmal))),Simu)
	}
# Funktion "simu.attr" für die Einstellwerte der attributiven Merkmale:
# 2 Werte: Merkmal und Anzahl (Simu)
# sample() zieht eine Stichprobe aus den Werten
# rep(a,b) wiederholt den Eintrag "a" b Mal
# levels(Merkmals) Stufen des Merkmals
# rmultinom: Zufallszahlen der Multinomialverteilung (2 oder mehr Gruppen im Merkmal)
# rmultinom(a,b,c) erzeugt a Mal Zufallswerte, je Durchlauf b Werte mit den Wahrscheinlichkeiten c je Stufe des Merkmals
# prog=table(Merkmal) gibt die Anzahl Werte je Stufe wieder, die in rmultinom automatisch in Anteile umgewandelt werden

sim.Lief=simu.attr(Lieferant,Simu)
# speichert Zufallswerte für Lieferant in sim.Lief
sim.Kund=simu.attr(Kunde,Simu)
sim.Meth=simu.attr(Methode,Simu)
sim.Rev=simu.attr(Review,Simu)
sim.Kompl=simu.attr(Komplexität,Simu)

sim.PL=abs(rnorm(Simu, mean(PL), sd(PL)))
# speichert Zufallswerte für PL in sim.PL
# abs() berechnet den Absolutwert
sim.PMa=ceiling(abs(rnorm(Simu, mean(PMa), sd(PMa))))
# ceiling berechnet die nächstgrößere ganze Zahl
sim.Abt=ceiling(abs(rnorm(Simu, mean(Abteilungen),sd(Abteilungen))))

# Zusammenstellung der Daten für die Monte Carlo-Simulation
sim.daten = data.frame(Lieferant=sim.Lief,Kunde=sim.Kund,Methode=sim.Meth,Review=sim.Rev,
	Komplexität=sim.Kompl,PL=sim.PL,PMa=sim.PMa,Abteilungen=sim.Abt)

# Berechnung der simulierten Laufzeit
Laufzeit.sim=predict(lm.2,sim.daten)
MC.daten=cbind(sim.daten,Laufzeit.sim)

# Boxplot simulierte Laufzeit nach Review, Methode und Komplexität
boxplot(Laufzeit.sim ~ Review+Methode+Komplexität, pch=8, col="lightgrey", lty=1,
        axes=FALSE, xlab="", ylab="", data=MC.daten)
mtext(side=1, line=3.5, at=c(2.5,6.5,10.5), levels(Komplexität))
mtext(side=1, line=3.5, at=-2.0, adj=c(0), "Komplexität")
mtext(side=1, line=2, at=seq(1.5,11.5,by=2), levels(Methode))
mtext(side=1, line=2, at=-2.0, adj=c(0), "Methode")
mtext(side=1, line=0.5, at=1:12, levels(Review))
mtext(side=1, line=0.5, at=-2.0, adj=c(0), "Review")
axis(1, at=1:12, labels=NA)
axis(2, las=2)
box()

# Boxplot simulierte Laufzeit nach Lieferant, Kunde und Komplexität
boxplot(Laufzeit.sim ~ Lieferant+Kunde+Komplexität, pch=8, col="lightgrey", lty=1,
        axes=FALSE, xlab="", ylab="", data=MC.daten)
mtext(side=1, line=3.5, at=c(2.5,6.5,10.5), levels(Komplexität))
mtext(side=1, line=3.5, at=-2.0, adj=c(0), "Komplexität")
mtext(side=1, line=2, at=seq(1.5,11.5,by=2), levels(Kunde))
mtext(side=1, line=2, at=-2.0, adj=c(0), "Kunde")
mtext(side=1, line=0.5, at=1:12, levels(Lieferant))
mtext(side=1, line=0.5, at=-2.0, adj=c(0), "Lieferant")
axis(1, at=1:12, labels=NA)
axis(2, las=2)
box()

#++++++++++++++++++++++++++++++++++++++++++++++++#
# S. 208: 95%-Prognosebereich
# Laufzeit.sim wurde berechnet

# Berechnung und Ausgabe der Quantilwerte
PI = quantile(Laufzeit.sim, prob=c(0.025,0.975))
PI

#++++++++++++++++++++++++++++++++++++++++++++++++#
# S. 217: 95%-Streubereich für die Anpassungsgüte R²
#lm.2 wurde berechnet

require(car) # Paket car laden

BTD.Laufzeit=Boot(lm.2,
	f = function(mod){summary.lm(mod)$r.squared},
	R=10^4)
# Boot(daten,funktion,anzahl,...) ist Bootstrapping-Funktion
# f gibt die Funktion für die Kennzahl R² an
# hier: R² aus der Zusammenfassung des Modells
# R: Anzahl Simulationsdurchläufe

confint(BTD.Laufzeit, level=.95, type="perc")
# berechnet den Streubereich von BTD.Laufzeit
# level Abdeckbereich
# perc: Perzentil- bzw. Quantil-Methode

#++++++++++++++++++++++++++++++++++++++++++++++++#
# S. 218: Boxplot
# Simulierte Anpassungsgüten BTD.Laufzeit sind berechnet
boxplot(BTD.Laufzeit$t, pch=8, col="lightgrey", lty=1)
# BTD.Laufzeit$t: simulierte BTD.Laufzeit-Anpassungsgüten
abline(h=c(0.8327,0.9262,0.8744), col="red")
# zeichnet drei horizontale Linien ein

#++++++++++++++++++++++++++++++++++++++++++++++++#
# S. 218: Zeitreihendiagramm
# Simulierte Anpassungsgüten BTD.Laufzeit sind berechnet
plot(BTD.Laufzeit$t)
# BTD.Laufzeit$t: simulierte BTD.Laufzeit-Anpassungsgüten
abline(h=c(0.8327,0.9262,0.8744), col="red")
# zeichnet drei horizontale Linien ein

#++++++++++++++++++++++++++++++++++++++++++++++++#
# S. 225: 95%-Streubereich für die Anpassungsgüte R²
# lm.2 wurde berechnet

require(car) # Paket car laden

BTR.Laufzeit=Boot(lm.2,
	f = function(mod){summary.lm(mod)$r.squared},
	R=10^4,
	method="residual")
# Boot(daten,funktion,anzahl,...) ist Bootstrapping-Funktion
# f gibt die Funktion für die Kennzahl R² an
# hier: R² aus der Zusammenfassung des Modells
# R: Anzahl Simulationsdurchläufe
# method wählt die Bootstrap-Methode, "residual": Residuen wie in (31)

confint(BTR.Laufzeit, level=.95, type="perc")
# berechnet den Streubereich von BTR.Laufzeit
# level Abdeckbereich
# perc: Perzentil- bzw. Quantil-Methode

#++++++++++++++++++++++++++++++++++++++++++++++++#
# S. 225: Boxplot
# Simulierte Anpassungsgüten BTR.Laufzeit sind berechnet
boxplot(BTR.Laufzeit$t, pch=8, col="lightgrey", lty=1)
# BTR.Laufzeit$t: simulierte BTR.Laufzeit-Anpassungsgüten
abline(h=c(0.8430,0.9083,0.8744), col="red")
# zeichnet drei horizontale Linien ein

#++++++++++++++++++++++++++++++++++++++++++++++++#
# S. 226: Zeitreihendiagramm
# Simulierte Anpassungsgüten BTR.Laufzeit sind berechnet
plot(BTR.Laufzeit$t)
# BTR.Laufzeit$t: simulierte BTR.Laufzeit-Anpassungsgüten
abline(h=c(0.8430,0.9083,0.8744), col="red")
# zeichnet drei horizontale Linien ein

## Kapitel 10 ##
#
# Optimierung und Nachweis

#++++++++++++++++++++++++++++++++++++++++++++++++#
# S. 236: Zielgrößenoptimierung
# lm.2 wurde berechnet

# Zielgrößenoptimierung
# Wunschfunktion d*_min als Funktion "d.min2" definieren
d.min2=function(y,OG,Ziel,w) {
  ifelse(y>OG, 0, ((OG-y)/(OG-Ziel))^w*100 ) }
# ifelse(Bedingung, A, B): prüft Bedingung für jedes Element
# und gibt A zurück wenn wahr und B wenn falsch

# Rasterwerte erstellen
d.PL=seq(min(PL),max(PL),length=100)
# seq() erstellt eine Sequenz von Werten
# min() liefert das Minimum
# max() liefert das Maximum
# length gibt an aus wie vielen Werte die Sequenz besteht
d.PMa=seq(min(PMa),max(PMa))
d.Abteilungen=seq(min(Abteilungen),max(Abteilungen))
d.Lieferant=levels(Lieferant)
# levels() gibt die Kategorien eines attributiven Merkmals aus
d.Kunde=levels(Kunde)
d.Methode=levels(Methode)
d.Review=levels(Review)
d.Komplexität=levels(Komplexität)

# Rasterwerte in einer Liste speichern
Raster.Liste = list(PL=d.PL, PMa=d.PMa,
	Abteilungen=d.Abteilungen, Lieferant=d.Lieferant,
	Kunde=d.Kunde, Methode=d.Methode,
	Review=d.Review, Komplexität=d.Komplexität)

# alle Kombinationen erzeugen
Raster = expand.grid(Raster.Liste)

# Prognosewerte berechnen und in Spalte "Prognose" anhängen
Raster[, "Prognose"] = c(predict(lm.2, Raster))
# Werte von d*_min berechnen und in Spalte "dmin2" anhängen
Raster[, "dmin2"] = d.min2(Raster$Prognose, OG=50, Ziel=25, w=1)

# Auswahl kurzer Projekte
kurze.Projekte = subset(Raster, Raster$dmin2 > 0)
#  subset() erstellt Auswahl nach Kriterium "Raster-Werte d*_min > 0"
dim(Raster)
dim(kurze.Projekte)
# dim() liefert die Dimensionen, d. h. Anzahl Zeilen (1. Wert) und Spalten (2. Wert)
summary(kurze.Projekte)
# summary() liefert Kennzahlen
Raster[Raster$dmin2==max(Raster$dmin2),]
# zeigt die Einstellungen an mit denen dmin2 maximal ist

#++++++++++++++++++++++++++++++++++++++++++++++++#
# S. 253: Finden der Kombinationen mit obere Prognosegrenze > 200 Tage
# lm.2 wurde berechnet

# Worst-Case-Wunschfunktion d*_max als Funktion "d.max" definieren
d.max=function(y,UG,Ziel,w) {
  ifelse(y<UG, 0,
		ifelse(y>Ziel, 100, ((y-UG)/(Ziel-UG))^w*100 ))
  }
# ifelse(Bedingung, A, B): prüft Bedingung für jedes Element
# und gibt A zurück wenn wahr und B wenn falsch

# Rasterwerte erstellen
d.PL=seq(min(PL),max(PL),length=100)
d.PMa=seq(min(PMa),max(PMa))
d.Abteilungen=seq(min(Abteilungen),max(Abteilungen))
d.Lieferant=levels(Lieferant)
d.Kunde=levels(Kunde)
d.Methode=levels(Methode)
d.Review=levels(Review)
d.Komplexität=levels(Komplexität)

# Rasterwerte in einer Liste speichern
Raster.Liste = list(PL=d.PL, PMa=d.PMa,
	Abteilungen=d.Abteilungen, Lieferant=d.Lieferant,
	Kunde=d.Kunde, Methode=d.Methode,
	Review=d.Review, Komplexität=d.Komplexität)

# alle Kombinationen erzeugen
Raster = expand.grid(Raster.Liste)

# Obere 99%-Prognosegrenze "OPG" berechnen
OPG = as.data.frame(predict(lm.2, Raster,
	interval="prediction", level=0.98))$upr
# predict(., interval="'prediction"') berechnet zweiseitige Prognosegrenzen
# level=0.98 Anteil innerhalb des zweiseitig begrenzten Prognoseintervalls an
# bei 98% innerhalb liegen 2% außerhalb, mit 1% > OPG
# $upr wählt obere Prognosegrenze (upper prediction limit) für OPG aus

# und in Spalte "OPG" anhängen
Raster[, "Prognosegrenze"] = OPG

# Projekte mit OPG>200 in "lange.projekte" speichern
lange.projekte=subset(Raster, Raster$Prognosegrenze > 200)
summary(lange.projekte)

#++++++++++++++++++++++++++++++++++++++++++++++++#
# S. 254 Einschränkung der Einstellkombinationen auf obere Prognosegrenze < 200 Tage
# Der Datensatz "lange.projekte" wurde erstellt

# Matrixplot für die variablen Merkmale PL, PMa und Abteilungen
require(lattice) # Paket lattice laden

lange.projekte.variabel = subset(lange.projekte, select=c(PL,PMa, Abteilungen))
# Auswahl der variablen Merkmale aus "lange.projekte"
splom (~lange.projekte.variabel)
# Matrixplot für alle variablen Einflüsse
# kaum sicherer Bereich identifizierbar

# Kombinationen der attributiven Merkmale erstellen
werte.attributiv = list(Lieferant=d.Lieferant, Kunde=d.Kunde,
                        Methode=d.Methode, Review=d.Review,
                        Komplexität=d.Komplexität)
kombi = expand.grid(werte.attributiv)

# Platzhalter "Anzahl" definieren, der so viele Stellen hat wie es Kombinationsmöglichkeiten der attributiven Merkmale gibt (hier: 48)
Anzahl=numeric(nrow(kombi))
# nrow() zählt Anzahl Zeilen (number of rows)

# Für alle Kombinationsmöglichkeiten in "kombi" zählen, wie oft (Anzahl) OPG > 200~Tage im Datensatz "lange.projekte" ist
for(i in 1:nrow(kombi)){
	Anzahl[i] = nrow(subset(lange.projekte,
		(Lieferant==kombi$Lieferant[i])
		& (Kunde==kombi$Kunde[i])
		& (Methode==kombi$Methode[i])
		& (Review==kombi$Review[i])
		& (Komplexität==kombi$Komplexität[i])))
	}

# Anfügen der Spalte "Anzahl" an "kombi" und speichern als Datensatz "Häufigkeit"
Häufigkeit=data.frame(cbind(kombi,Anzahl))
# data.frame() erstellt Datenstruktur
# cbind() verbindet Spalten (column bind)

# Auswahl der Kombinationen, in denen nie OPG > 200 bzw. Anzahl(OPG>200)=0 ist
Sicher=subset(Häufigkeit, Anzahl==0)

summary(Sicher)
# Kennzahlen für Datensatz "Sicher"
# kein attributives Merkmal hat bei Projekten mit OPG <= 200 immer dieselbe Einstellung
# tendenziell Merkmal Komplexität am eindeutigsten

# Kombinationen der attributiven Merkmale mit OPG kleiner 200~Tage je Komplexitäts-Level
subset(Sicher, Komplexität=="hoch")
subset(Sicher, Komplexität=="mittel")
subset(Sicher, Komplexität=="niedrig")

## Kapitel 11 ##
#
# Toleranzen

#++++++++++++++++++++++++++++++++++++++++++++++++#
# S. 265: Test auf Normalverteilung und Wahrscheinlichkeitsnetz
# Daten PLZ_1.CSV sind eingelesen und mit attach(PLZ_1.CSV) verfügbar gemacht

# Test auf Normalverteilung (Anderson-Darling)
require(nortest) # Paket nortest laden
ad.test(Laufzeit)
# berechnet den Anderson-Darling-Test auf Normalverteilung (ad.test) und gibt die Werte aus

# Wahrscheinlichkeitsnetz
qqnorm(Laufzeit, xlab="Normalverteilungs-Quantile",
	ylab="Laufzeit", main="Wahrscheinlichkeitsnetz", pch=20)
qqline(Laufzeit, col="blue")
# qqnorm zeichnet Wahrscheinlichkeitsnetz für Normalverteilung
# xlab, ylab, main: Beschriftung x-Achse, y-Achse und Titel
# qqline zeichnet Ideallinie (hier: blau)

#++++++++++++++++++++++++++++++++++++++++++++++++#
# S. 271: Toleranzgrenze ohne Normalverteilung
# Daten PLZ_1.CSV sind eingelesen

require(tolerance) # für die Toleranzrechnung muss das Package "tolerance" installiert sein

nptol.int(Laufzeit, alpha=0.05, P=0.99, side=1)
# nptol.int() berechnet verteilungsfreie Toleranzintervalle
# alpha=0.05 entspricht Konfidenz- oder Vertrauensniveau von 95%
# P=0.99 Abdeckung der Laufzeit (99%)
# side=1 berechnet einseitige Toleranzgrenzen

distfree.est(n = length(Laufzeit), P = 0.99, side = 1)
# berechnet die erreichte Konfidenz für 99% Abdeckung bei n=132 Werten

distfree.est(n = length(Laufzeit), alpha=0.05, side = 1)
# berechnet die erreichbare Abdeckung bei n=132 Werten und 95% Konfidenz

distfree.est(P=0.99, alpha=0.05, side = 1)
# berechnet die Mindestanzahl Messwerte für 99% Abdeckung und 95% Konfidenz

#++++++++++++++++++++++++++++++++++++++++++++++++#
# S. 277: Monte Carlo-Toleranz
# Daten PLZ_1.CSV sind eingelesen und mit attach(PLZ_1.CSV) verfügbar gemacht
# lm.2 wurde berechnet

Simu=10^4 # Anzahl Simulationen in "Simu" speichern

# Zusammenstellung der Daten für die Monte Carlo-Simulation
sim.PL=abs(rnorm(Simu, mean(PL), sd(PL)))
sim.PMa=ceiling(abs(rnorm(Simu, mean(PMa), sd(PMa))))
sim.Abt=ceiling(abs(rnorm(Simu, mean(Abteilungen),sd(Abteilungen))))
sim.daten = data.frame(Lieferant="ja",Kunde="ja",Methode="SiSi",Review="ja",Komplexität="hoch",PL=sim.PL,PMa=sim.PMa,Abteilungen=sim.Abt)

# Berechnung der simulierten Projektdurchlaufzeiten
Laufzeit.sim=predict(lm.2,sim.daten)
MC.daten=cbind(sim.daten,Laufzeit.sim)

# Boxplot simulierte Laufzeit
boxplot(Laufzeit.sim, pch=8, col="lightgrey", lty=1, data=MC.daten)

# Test auf Normalverteilung (Anderson-Darling) und Wahrscheinlichkeitsnetz
require(nortest) # Paket nortest laden
ad.test(Laufzeit.sim)

qqnorm(Laufzeit, xlab="Normalverteilungs-Quantile",
	ylab="Laufzeit", main="Wahrscheinlichkeitsnetz", pch=20)
qqline(Laufzeit, col="blue")

# Berechnen der 99%-Toleranzgrenze
require(tolerance) # Paket tolerance laden

nptol.int(Laufzeit.sim, alpha=0.05, P=0.99, side=1)
distfree.est(n = length(Laufzeit.sim), P = 0.99, side = 1)

#++++++++++++++++++++++++++++++++++++++++++++++++#
# S. 291: Bootstrap-Toleranz
# Daten PLZ_1.CSV sind eingelesen und mit attach(PLZ_1.CSV) verfügbar gemacht
# lm.2 wurde berechnet

# Einstellwerte für Prognose
x.p = data.frame(Lieferant="ja",Kunde="ja",Methode="SiSi",
	Review="ja",Komplexität="hoch", PL=median(PL),PMa=median(PMa),
	Abteilungen=median(Abteilungen))

# Prognosewert ydach_p
y.p = predict(lm.2,x.p)

# modifizierte Residuen
ri = lm.2$res/sqrt(1-lm.influence(lm.2)$hat) - mean(lm.2$res/sqrt(1-lm.influence(lm.2)$hat))
# lm.2$res Residuen von lm.2
# sqrt() Wurzelfunktion
# lm.influence(lm.2)$hat Hebelwirkungen von lm.2
# mean() Mittelwert

# Einstellwerte für SPM
x.werte = subset(PLZ.1, select=c(PL, PMa, Abteilungen, Lieferant, Kunde, Methode, Review, Komplexität))
# Auswahl der Spalten mit Einstellwerten

Simu=10^4 # Anzahl Simulationen in "Simu" speichern

# Container für "delta.stern" und "y.sim" definieren
delta.stern = NULL
y.sim = NULL

# Werte "delta.stern" und "y.sim" berechnen
for(i in 1:Simu){
	e.stern = sample(ri, size=nrow(PLZ.1), replace=TRUE)
	y.stern = lm.2$fit + e.stern
	lm.2.stern = lm(y.stern ~ PL + PMa + Abteilungen + Lieferant
		+ Kunde + Methode + Review + Komplexität  + I(PMa^2)
		+ PL:PMa + Abteilungen:Methode + Lieferant:Kunde
		+ Kunde:Komplexität + Methode:Review,
		data=cbind(x.werte,y.stern))
	y.p.stern = predict(lm.2.stern,x.p)
	e.p.stern = sample(ri, size=nrow(x.p), replace=TRUE)
	delta.stern[i] = y.p.stern - (y.p+e.p.stern)
	# i-ter Wert für delta.stern
	y.sim[i] = y.p + delta.stern[i]
	# i-ter simulierte Bootstrap-Prognosewert
	}

# Boxplot simulierte Laufzeit
boxplot(y.sim, pch=8, col="lightgrey", lty=1)

# Test auf Normalverteilung (Anderson-Darling) und Wahrscheinlichkeitsnetz
require(nortest) # Paket nortest laden
ad.test(y.sim)

qqnorm(y.sim, xlab="Normalverteilungs-Quantile",
	ylab="Laufzeit", main="Wahrscheinlichkeitsnetz", pch=20)
qqline(y.sim, col="blue")

# Berechnen der 99%-Toleranzgrenze
require(tolerance) # Paket tolerance laden
normtol.int(y.sim, alpha=0.05, P=0.99, side=1)
# normtol.int() berechnet Toleranzgrenzen für normalverteilte Werte


# Conversion from Grey to RGB uses the following code
setAs("pixmapGrey", "pixmapRGB",
function(from, to){
    z = new(to, as(from, "pixmap"))
    z@red = from@grey
    z@green = from@grey
    z@blue = from@grey
    z@channels = c("red", "green", "blue")
    z
})

# Conversion from RGB to grey uses built-in coefficients of 0.3, 0.59, 0.11.  To see this, type
getMethods(addChannels)

# We can override this behaviour with
setMethod("addChannels", "pixmapRGB",
function(object, coef=NULL){
    if(is.null(coef)) coef = c(0.2126, 0.7152, 0.0722)
    z = new("pixmapGrey", object)
    z@grey = coef[1] * object@red + coef[2] * object@green +
        coef[3] * object@blue
    z@channels = "grey"
    z
})

# Colour image
plot(p1 <- pixmapRGB(c(c(1,0,0,0,0,1), c(0,1,0,0,1,0), c(0,0,1,1,0,0)), nrow=6, ncol=6))

#Convert to grey
plot(p2 <- as(p1, "pixmapGrey"))

# Convert back to "colour"
plot(p3 <- as(p2, "pixmapRGB"))


library("caret")
library("recipes")
library("ggplot")

place_po_sektorjih %>% View
place_po_sektorjih %>% filter(IZOBRAZBA != "Izobrazba - Skupaj") %>%
  ggplot(aes(x=POVPRECNA_PLACA, fill=factor(IZOBRAZBA))) +
  geom_histogram(binwidth=100)

inTrain <- createDataPartition(
  y = place_po_sektorjih$POVPRECNA_PLACA,
  ## the outcome data are needed
  p = .75,
  ## The percentage of data in the
  ## training set
  list = FALSE
)

training <- place_po_sektorjih[ inTrain,]
testing  <- place_po_sektorjih[-inTrain,]

preProcessValues <-preProcess(training,method = c("BoxCox","center","scale"))
trainTransformed <- predict(preProcessValues, training)
trainTransformed


sierpinski.triangle = function(n) {
	c(paste(ifelse(b<<- c(rep(FALSE,2^(n+1)/2),TRUE,rep(FALSE,2^(n+1)/2)),"*"," "),collapse=""),replicate(2^n-1,paste(ifelse(b<<-xor(c(FALSE,b[1:2^(n+1)]),c(b[2:(2^(n+1)+1)],FALSE)),"*"," "),collapse="")))
}
cat(sierpinski.triangle(5),sep="\n")


#######################################################
#Scripts used to conduct logistic regression analyses #
#on data in S1 Table and S2 Table, easily modified to #
#test effects of particular animals, vector species,  #
#and other variables.                                 #
#######################################################

# Directory
setwd('/Your/Working/Directory/')

# Library
library(data.table)
#library(ROCR)

# Read
KHdata <- fread('S1 Table. Kafta Humera data.csv', data.table = F)

# Naming and Recoding
names(KHdata) <- c('Method-ID','Date','Trap','Sand_Fly_Species','Locality','Habitat','Blood_Meal_Source')

KHdata$animal <- KHdata$Blood_Meal_Source

KHdata$Blood_Meal_Source[KHdata$Blood_Meal_Source == 'human'] <- 1
KHdata$Blood_Meal_Source[grep('human', KHdata$Blood_Meal_Source)] <- 1
KHdata$Blood_Meal_Source[KHdata$Blood_Meal_Source != '1'] <- 0
KHdata$Blood_Meal_Source <- as.integer(KHdata$Blood_Meal_Source)

KHdata$animal[KHdata$animal %in% c('human','negative')] <- 0
KHdata$animal[KHdata$animal != '0'] <- 1
KHdata$animal <- as.integer(KHdata$animal)

KHdata$Habitat[KHdata$Habitat %in% c('in_village','periphery_of_village','domestic_habitat','peridomestic','indoors')] <- 'village'

############
# Modeling #
############

# GLM
mod <- glm(formula = Blood_Meal_Source ~ Habitat + animal, family = binomial(), data = KHdata)
summary(mod)

##############################################
# Adding data from Gebresilassie et al. 2015 #
##############################################

human_only_village <- c('0','Phlebotomus orientalis','0','village',1,0)
human_animal_village <-  c('0','Phlebotomus orientalis','0','village',1,1)
animal_only_village <-  c('0','Phlebotomus orientalis','0','village',0,1)
negative_village <-  c('0','Phlebotomus orientalis','0','village',0,0)

human_only_ff <- c('0','Phlebotomus orientalis','0','farm_fields',1,0)
human_animal_ff <-  c('0','Phlebotomus orientalis','0','farm_fields',1,1)
animal_only_ff <-  c('0','Phlebotomus orientalis','0','farm_fields',0,1)
negative_ff <-  c('0','Phlebotomus orientalis','0','farm_fields',0,0)

gebrtable <- as.data.frame(rbind(human_only_village, human_animal_village, animal_only_village, negative_village, human_only_ff, human_animal_ff, animal_only_ff, negative_ff), stringsAsFactors = F)
gebrtable[,5] <- as.numeric(gebrtable[,5])
gebrtable[,6] <- as.numeric(gebrtable[,6])
names(gebrtable) <- names(KHdata)

######################################################
# Build table using counts (in order defined above)  #
# from S2 Table. Tahtay Adiyabo data.csv"            #
######################################################

gebrtable2 <- c(40, 47, 360, 55, 13, 7, 92, 23)

for (i in 1:length(gebrtable2)) {
  for (j in 1:gebrtable2[i]) {
    KHdata <- rbind(KHdata, gebrtable[i,])
  }
}

# Modeling

mod <- glm(formula = Blood_Meal_Source ~ Habitat + animal family = binomial(), data = KHdata)
summary(mod)

non_meta <- glm(formula = Blood_Meal_Source ~ Habitat + animal, family = binomial(), data = KHdata[747:1383,])
summary(non_meta)


setwd("~/Dokumenty/studijni_materialy/DP/data")

chunks <- function(d, n){
  chunks <- split(d, ceiling(seq_along(d)/n))
  names(chunks) <- NULL
  return(chunks)
}

s2chunk2int <- function(ch){
  ch <- unlist(ch)
  if(length(ch)!= 2){
    #print("not size")
    #print(ch)
    return()
  }
  num <- ch[1]*2^0+ch[2]*2^1
  return(num)
}

s4chunk2int <- function(ch){
  ch <- unlist(ch)
  if(length(ch)!= 4){
    #print("not size")
    #print(ch)
    return()
  }
  num <- ch[1]*2^0+ch[2]*2^1+ch[3]*2^2+ch[4]*2^3
  return(num)
}

s8chunk2int <- function(ch){
  ch <- unlist(ch)
  if(length(ch)!= 8){
    #print("not size")
    #print(ch)
    return()
  }
  num <- ch[1]*2^0+ch[2]*2^1+ch[3]*2^2+ch[4]*2^3 + ch[5]*2^4+ch[6]*2^5+ch[7]*2^6+ch[8]*2^7
  return(num)
}

minEntropy <- function(cMax, N, W){
  pMax <- cMax/N
  cBound <- cMax + 2.3*sqrt(N * pMax*(1 - pMax))
  H <- -log2(cBound/N)
  return(min(W,H))
}

frequency <- function(cMax, N){
  alpha <- 0.005
  #print(cMax)
  #print(N)
  epsilon <- sqrt(log(1/(1-alpha))/(2*N))
  #print(epsilon)
  pMax <- cMax/N
  return(-log2(pMax + epsilon))
}

fileName <- "teaching.txt"
conn <- file(fileName,open="r")
linn <-readLines(conn)
#data <- c(unlist(strsplit(linn[1], split="")))
ones <- c(NA)
zeros <- c(NA)
monobit <- c(NA)
minEn4 <- c(NA)
minEn8 <- c(NA)
freqE4 <- c(NA)
freqE8 <- c(NA)
lengths <- c(NA)
lengths2 <- c(NA)
lines = 0
for (i in 1:length(linn)){
  #data <- c(data,unlist(strsplit(linn[i], split="")))
  line <- as.numeric(unlist(strsplit(linn[i], split="")))
  if("1" %in% line){
    lines <- lines + 1
    lengths2 <- c(lengths2, length(line))
    #ch2 <- chunks(line,2)
    ch4 <- chunks(line,4)
    ch8 <- chunks(line,8)
    numbers2 <- c(NA)
    numbers4 <- c(NA)
    numbers8 <- c(NA)
    #for(i in ch2){
    #  numbers2 <- c(numbers2,s2chunk2int(i))
    #}
    for(i in ch4){
      numbers4 <- c(numbers4,s4chunk2int(i))
    }
    for(i in ch8){
      numbers8 <- c(numbers8,s8chunk2int(i))
    }
    minEn8 <- c(minEn8,minEntropy(max(table(numbers8)), length(numbers8),8) * length(numbers8))
    minEn4 <- c(minEn4,minEntropy(max(table(numbers4)), length(numbers4),4) * length(numbers4))
    freqE8 <- c(freqE8,frequency(max(table(numbers8)), length(numbers8)) * length(numbers8))
    freqE4 <- c(freqE4,frequency(max(table(numbers4)), length(numbers4)) * length(numbers4))
    #print(table(numbers8))
  }
  split(linn, ceiling(seq_along(linn)/4))
  #hist(line)
  #print(mean(line))
  ones <- c(ones,sum(line == 1))
  zeros <- c(zeros,sum(line == 0))
  monobit <- c(monobit, mean(line))
  lengths <- c(lengths, length(line))

}
close(conn)

#print(ones)
#print(zeros)
print(mean(na.omit(minEn4)))
print(mean(na.omit(minEn8)))

print(mean(na.omit(freqE8)))
print(mean(na.omit(freqE4)))

#data <- as.numeric(data)


#' paleohydror: A package for implementing published routines in paleohydrologic reconstruction.
#'
#' This package offers several functions and routines for deriving estimates of paleohydrology from field observations of rock outcrops. Data such as grain size are important too.
#'
#' @section paleohydror functions:
#'
#' The functions here make up a mix of tools to calculate and estimate modern suficial processes and back-calculate those processes in ancient rivers.
#'
#' \code{settle} calculates the settling velocity of particles following the formulation by Dietrich (1982).
#'
#' \code{lynds_one} estimates ancient river slope using the first method described by Lynds et al. (2014)
#'
#' \code{lynds_two} estimates ancient river slope using the second method described by Lynds et al. (2014)
#'
#' \code{lynds_three} estimates ancient river slope using the third method described by Lynds et al. (2014)
#'
#' \code{xset2H} estimates ancient river dune heights based on cross-set thicknesses. Methods from Leclair and Paola.
#'
#' \code{H2h} estimates ancient river depths based on dune heights. Methods from Bradley and Venditti.
#'
#' \code{xset2depthSimple} estimates ancient river depths directly from cross-set thicknesses using the simplest assumptions. Methods from Leclair, Paola, and Bradley and Venditti.
#'
#' \code{azStringConvert} Azimuth conversion for 'quadrant' based strike/trend measurements.
#'
#' \code{ancient_1} Estimating sediment flux in ancient rivers following Mahon + McElroy (2018).
#'
#' \code{modern_1} Estimating sediment flux in modern rivers if bedform height is known following Mahon + McElroy (2018).
#'
#' \code{modern_2} Estimating sediment flux in modern rivers if bedform length is known following Mahon + McElroy (2018).
#'
#' \code{bedform_velocity} Estimating bedform migration rate as a function of reach-averaged slope.
#'
#' \code{bedform_bedload} Estimating bedload as a function of bedform height and migration rate. After Simons et al. (1965)
#'
#' \code{height_length} Estimating bedform height if bedform length is known.
#'
#' \code{trampush_slp} estimates paleoslope using an empirical relationship with median bedload grain size and bankfull flow depth from Trampush (2014).
#'
#'
#'
#'
#'
#' @docType package
#' @name paleohydror
NULL


ui <- fluidPage(titlePanel("Likelihood Ratio for Mixed Results"),
  sidebarLayout(
    sidebarPanel(numericInput("n", "Number of studies :", 3, min = 1, max = 100),
                 numericInput("x", "Number of successes:", 2, min = 0, max = 100),
                 sliderInput("H0", "Type 1 error rate:", min = 0, max = 1, value = 0.05, step= 0.01),
                 sliderInput("H1", "Assumed Power:", min = 0, max = 1, value = 0.8, step= 0.01)
                 ),
    mainPanel(plotOutput("coolplot"),br(),
              h4("Shiny app accompanying: Lakens, D., & Etz, A. J. (2017). Too true to be bad: When sets of studies with significant and non-significant findings are probably true. Social Psychological and Personality Science. https://osf.io/preprints/psyarxiv/nnkg9"),br(),
              h4(textOutput("text1")), br(),
              h4(textOutput("text2")),br(),
              h4("When the observed results are equally likely under H0 and H1, the likelihood ratio is 1. Benchmarks to interpret Likelihood Ratios suggest that when 1<LR<8 there is weak evidence, when 8<LR<32 there is moderate evidence, and when LR>32, there is strong evidence."),br(),
              h4(textOutput("text3")), br(),
              dataTableOutput("table")
    )
  )
)


# Load necessary libraries

year <- c(2018:2058)

data <- data.frame(year)
data$lngdppc <- 4.5 + .02*(year-2018)
data$sinv  <- .2
data$ky    <- 3.5
data$phil  <- .75

fig <- plot_ly(data, x = ~year, y = ~lngdppc, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'BGP log GDP per capita', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Log of GDP per capita',range=c(4,5.5)),
              hovermode="x unified")
api_create(fig, filename = "me-bgp-lngdppc")

fig <- plot_ly(data, x = ~year, y = ~sinv, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'BGP capital formation/GDP', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Ratio of I/Y',range=c(0,1)),
              hovermode="x unified")
api_create(fig, filename = "me-bgp-sinv")

fig <- plot_ly(data, x = ~year, y = ~phil, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'BGP labor share of costs', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Ratio of W/(W+RK)',range=c(0,1)),
              hovermode="x unified")
api_create(fig, filename = "me-bgp-phil")

fig <- plot_ly(data, x = ~year, y = ~ky, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'BGP capital/output ratio', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Ratio of K/Y',range=c(1,5)),
              hovermode="x unified")
api_create(fig, filename = "me-bgp-ky")


png('ear_dilution.png')
hist(log2(ear00$mouse6c),col=rgb(1,0,0,0.25),xlim=c(-1,8),border=NA,freq=F,main="Ear histone dilution",xlab="log2(Histone Intensity)")
hist(log2(ear00$mouse6d),col=rgb(1,0,0,0.25),border=NA,freq=F,add=T)
hist(log2(ear00$mouse1k),col=rgb(1,0,0,0.25),border=NA,freq=F,add=T)
hist(log2(ear07$mouse1c),col=rgb(0,1,0,0.25),border=NA,freq=F,add=T)
hist(log2(ear07$mouse1i),col=rgb(0,1,0,0.25),border=NA,freq=F,add=T)
hist(log2(ear07$mouse1j),col=rgb(0,1,0,0.25),border=NA,freq=F,add=T)
hist(log2(ear12$mouse6e),col=rgb(0,0,1,0.25),border=NA,freq=F,add=T)
hist(log2(ear12$mouse6g),col=rgb(0,0,1,0.25),border=NA,freq=F,add=T)
hist(log2(ear12$mouse1a),col=rgb(0,0,1,0.25),border=NA,freq=F,add=T)
hist(log2(ear18$mouse1d),col=rgb(1,1,0,0.25),border=NA,freq=F,add=T)
hist(log2(ear18$mouse1e),col=rgb(1,1,0,0.25),border=NA,freq=F,add=T)
hist(log2(ear18$mouse1f),col=rgb(1,1,0,0.25),border=NA,freq=F,add=T)
legend("topleft", c("0 day", "7 day", "12 day", "18 day"), col=c("red","green","blue","yellow"), lwd=10)
dev.off()


#' eig
#'
#' Eigenvalue decomposition.
#'
#' @details
#' Runtime performance for a SymMat (symmetric packed matrix) will be
#' MUCH slower than when using full (non-packed) storage.
#'
#' @param x
#' The input matrix.
#' @param only.values
#' Should only the eigenvalues be returned, or should the eigenvectors
#' also be returned?
#' @param descending
#' Should the values/vectors be returned in descending order,
#' or ascending order?  By default, LAPACK returns them in ascending
#' order, so putting them in descending order (R's default in \code{eigen()})
#' has a performance cost.
#'
#' @return
#' A matrix-like object of the same type as the input.
#'
#' @export
eig <- function(x, only.values=FALSE, descending=TRUE)
{
  UseMethod("eig")
}

#' @export
eig.default <- function(x, only.values=FALSE, descending=TRUE)
{
  stop("Unsupported class 'x'")
}

#' @export
eig.SymMat <- function(x, only.values=FALSE, descending=TRUE)
{
  n <- getdim(x)[1L]
  triangle <- x@triangle

  data <- getData(x)
  storage.mode(data) <- "double"

  .Call(R_eig_sympacked, data, n, triangle, only.values, descending)
}

#' @export
eig.matrix <- function(x, only.values=FALSE, descending=TRUE)
{
  if (!is.double(x))
    storage.mode(x) <- "double"

  .Call(R_eig_full, x, only.values, descending)
}


test.auc <- function()
{
    checkEqualsNumeric(auc(c(1,0,1,1), c(.32,.52,.26,.86)), 1/3)
    checkEqualsNumeric(auc(c(1,0,1,0,1),c(.9,.1,.8,.1,.7)), 1)
    checkEqualsNumeric(auc(c(0,1,1,0),c(.2,.1,.3,.4)), 1/4)
    checkEqualsNumeric(auc(c(1,1,1,1,0,0,0,0,0,0),0*(1:10)), 0.5)
}


########################### BayesKin ###########################
## Bayesian estimates of rigid body kinematics
## Andy Pohl
## UofC - Faculty of Kinesiology

## Written by: Andy Pohl
## UofC - Faculty of Kinesiology
## June-Dec 2020
## Revision 1: June 2021
################################################################

##################### example.r  ###################
## Performs analysis comparing Bayesian to Least squares approaches for
## 3 link kinematic chains.
################################################################
rm(list = ls())
WORKING_DIR = "" # Replace with the location of the BayesKin/src directory on the local PC.

setwd(WORKING_DIR)
INIT_TYPE = 'ls_est' # specify the type of initial values to be used for MCMC sampling - either 'true_vals', 'ls_est', 'random
source('library.r') # Retrieve function library
set.seed(1)  # Set seed for reproducibility

## 1) Specify parameters
n.links = 3                             # Number of links.
seg.length = c(0.45, 0.35, 0.25)        # Length of segment
r_true = c(0.07, 0.03)                  # Origin location in m.
theta_true = c(-55, -110, -10)          # Rotation angle in deg.
sigma_true = 1.5/1000                   # Measurement noise in m.
true_vals = c(r_true = r_true, theta_true = theta_true, sigma_true = sigma_true)

# Generate posture
links = list(gen_link(seg.length = seg.length[1],
                      plate.center = 0.7*seg.length[1]),
             gen_link(seg.length = seg.length[2],
                      plate.center = 0.5*seg.length[2]),
             gen_link(seg.length = seg.length[3],
                      plate.center = 0.5*seg.length[3]))
posture = gen_posture(links, r = r_true, theta = theta_true)

# posture is a list with entries $r containing the location of the origin, $J containing the location of each joint
# where J[[1]] is the origin and J[[4]] is the termination of the kinematic chain. $alpha gives the actual position markers

# Generate observation
y = gen_obs(posture, sigma_true)
# y is a list of length nlinks with each list item containing a 2xnmarkers array of observed marker locations in the
# global frame.

plot_system(posture, y=y) # Provides a visualisation of the pose with observed markers in orange and true positions in blue

## 2) Apply LS or Bayesian models
#Compute LS solution.
LS_result = LS_soln(y, links,
                    inits = c(r_true, theta_true, sigma_true),
                    init_type = 'true_vals')

LS_result
# The output of LS_result contains estimates of r and theta_i given by r.hat, theta.hat and $sigma.hat
# along with 95% confidence intervals for each parameter in $intervals.  $time denotes the computation time of the LS solution
# $value provides the value of the cost function at the LS estimate.

# Compute a Bayesian solution
Bayes_result = Bayes_soln(y=y,
                          links = links,
                          mdlfile = './BayesModel_p3.jags', # choose what model to use by specifying the appropiate .jags file here.
                          init_type = INIT_TYPE,
                          true_vals = true_vals,
                          ls_est = c(LS_result$r.hat, LS_result$theta.hat, LS_result$sigma.hat))
# Bayes_result provides a list with $fit being a 'coda' object containing the MCMC samples for the fitted model
# $time provides the computational
summary(Bayes_result$fit) # provides posterior means for each pose parameter along with their 95% credible interval (via 2.5 and 97.5 quantiles)
plot(Bayes_result$fit) # provides traceplots and density estimates for each parameter.


set.seed(1234)

m = 100000
n = 500
x = rbind(
  matrix(rnorm(m/2*n), ncol=n),
  matrix(rnorm(m/2*n, mean=10), ncol=n)
)
y = c(rep(1L, m/2), rep(2L, m/2))
perm = sample(m)
x = x[perm, ]
y = y[perm]

test = rbind(
  matrix(rnorm(3*n), ncol=n),
  matrix(rnorm(2*n, mean=10), ncol=n),
  matrix(rnorm(15*n), ncol=n),
  matrix(rnorm(10*n, mean=10), ncol=n)
)

t1 = system.time(m1 <- class::knn1(train=x, cl=y, test=test))
t2 = system.time(m2 <- knn::knn(x, y, test))

t1
t2
t1[3]/t2[3]

all.equal(as.integer(m1), m2)


# Supporting function for the analysis of the data from the Fear Generalization Task (FGT) in the SAM study
# Written by Milou Sep

FGT_LM.Condition <- function(dataset){

  # Compare Conditions
  Base<-with(expr=lm(FPS~1),data = dataset)
  Main_Condition<-with(expr=lm(FPS~1+Condition),data = dataset)
  # Compare models
  Condition <- pool.compare(Main_Condition, Base, method='wald')

  # Make vectors for data in each row
  Main.effect.Condition <- c("Condition", Condition$Dm, Condition$rm, Condition$df1, Condition$df2, Condition$pvalue)

  WORD.table.FGT <- data.frame(rbind( Main.effect.Condition))
  colnames(WORD.table.FGT) <- c("Model", "Dm", "rm", "df1", "df2", "pvalue")

  # Data cells need to be changed to numeric (not factor), otherwise problems with flextable().
  WORD.table.FGT[c(2,3,4,5,6)] <- sapply(WORD.table.FGT[c(2,3,4,5,6)], as.character) # First convert to character ..
  WORD.table.FGT[c(2,3,4,5,6)] <- sapply(WORD.table.FGT[c(2,3,4,5,6)], as.numeric) # .. then to numeric

  # Return function output --------------------------------------------------

  return(WORD.table.FGT)

}


#set the working directory specific to my machine
setwd("/Users/romeokienzler/Documents/proj/1watsoniot/yt/clustering/HMP_Dataset")

#create a data frame from all files in specified folder
create_activity_dataframe = function(activityFolder,classId) {
  file_names = dir(activityFolder)
  file_names = lapply(file_names, function(x){ paste(".",activityFolder,x,sep = "/")})
  your_data_frame = do.call(rbind,lapply(file_names,function(x){read.csv(x,header = FALSE,sep = " ")}))
  your_data_frame = cbind(data.frame(rep(classId,nrow(your_data_frame))),your_data_frame)
  your_data_frame = cbind(data.frame(1:nrow(your_data_frame)),your_data_frame)
  colnames(your_data_frame) = c("timestep","class","x","y","z")
  your_data_frame = cbind(mean(your_data_frame$x),mean(your_data_frame$y),mean(your_data_frame$z),your_data_frame)
  colnames(your_data_frame) = c("mx","my","mz","timestep","class","x","y","z")
  your_data_frame
}

df1 = create_activity_dataframe("Brush_teeth",1)
df2 = create_activity_dataframe("Climb_stairs",2)
df = rbind(df1,df2)
View(df)
library(e1071)

#SPLIT
sample <- sample.int(nrow(df), floor(.75*nrow(df)), replace = F)
dftrain <- df[sample, ]
dftest <- df[-sample, ]
xtrain <- subset(dftrain, select=-dftrain$class)
ytrain <- dftrain$class
xtest <- subset(dftest, select=-dftest$class)
ytest <- dftest$class
svm_model <- svm(xtrain,ytrain)
pred <- predict(svm_model,xtest)
truthVector = round(pred) == dftest$class
good = length(truthVector[truthVector==TRUE])
bad = length(truthVector[truthVector==FALSE])
good/(good+bad)


#' @title Compute abnormal changes in data - historic baseline
#'
#' @description
#' The function allows to compute changes in search scores, voi, and doi and
#' shows percentile of changes to identify abnormal changes. In combination with
#' various *write* functions in R, the functions allow exports from the
#' database to local files.
#'
#' @details
#' The function computes abnormal changes in search scores, VOI, or DOI for each
#' date. We define "abnormal" in terms of deviation from a historic baseline
#' value. To compute the historic baseline value, the function computes a moving
#' average. Users can specify the window for moving average training
#' `train_win` and a break between training and the given date
#' `train_break`. Abnormal changes are the difference between the moving
#' average and the respective search score, VOI, or DOI. To highlight abnormal
#' changes, the function computes a historic percentile rank for each abnormal
#' change within the distribution of abnormal changes. Low percentile ranks
#' signify abnormally high negative changes. High percentile ranks signify
#' abnormally high positive changes.
#' The function uses the output from `export_...` functions as input. As
#' `get_abnorm_hist` offers no additional filters, users are advised to use
#' filters in the `export_...` functions or to pre-process data before
#' using `get_abnorm_hist`.
#'
#' @param data Object of class `exp_score`, `exp_voi` or
#' `exp_doi` generated through `export_...` functions.
#' @param train_win Object of type `numeric`. Length of rolling average
#' training window in months. Defaults to 12.
#' @param train_break Object of type `numeric`. Length of break between
#' rolling average training window and date in months. Defaults to 1.
#' @inheritParams export_control
#' @param type Object of type `character` indicating the type of time
#' series-column from data_score, takes either *obs*, *sad*, or
#' *trd*. Defaults to *"obs"*.
#' @param measure Object of type `character` indicating the measure used
#' for DOI computation for which abnormal changes should be analyzed. Takes
#' either *gini*, *hhi*, or *entropy*. Defaults to *"gini"*.
#'
#' @return
#' The functions export and filter the respective database tables and return
#' objects of class `"tbl_df", "tbl", "data.frame"`.
#' \itemize{
#'   \item Input class `exp_score` computes abnormal changes in search
#'   scores with columns keyword, location, date, control, object, score,
#'   score_abnorm, quantile. Object of class
#'   `c("abnorm_score", "data.frame")`.
#'   \item Input class `exp_voi` computes abnormal changes in VOI with
#'   columns keyword, date, control, object, voi, voi_abnorm, quantile. Object
#'   of class `c("abnorm_voi", "data.frame")`.
#'   \item Input class `exp_doi` computes abnormal changes in DOI with
#'   columns keyword, locations, date, control, object, doi, doi_abnorm,
#'   quantile. Object of class `c("abnorm_doi", "data.frame")`.
#' }
#'
#' @seealso
#' * [export_score()]
#' * [export_voi()]
#' * [export_doi()]
#' * [dplyr::filter()]
#'
#' @examples
#' \dontrun{
#' data <- export_score(keyword = "amazon")
#' get_abnorm_hist(data, train_win = 12, train_break = 0, type = "obs")
#'
#' data <- export_voi(keyword = "amazon")
#' get_abnorm_hist(data, train_win = 12, train_break = 0, type = "obs")
#'
#' data <- export_score(keyword = "amazon")
#' get_abnorm_hist(data, train_win = 12, train_break = 0, measure = "gini")
#' }
#'
#' @rdname get_abnorm_hist
#' @export
#' @importFrom dplyr group_by
#' @importFrom dplyr lag
#' @importFrom dplyr mutate
#' @importFrom dplyr percent_rank
#' @importFrom dplyr ungroup
#' @importFrom rlang .data
#' @importFrom zoo rollmean

get_abnorm_hist <- function(data, ...) UseMethod("get_abnorm_hist", data)

#' @rdname get_abnorm_hist
#' @export

get_abnorm_hist.exp_score <- function(data, train_win = 12, train_break = 0, type = "obs") {
  .check_length(train_win, 1)
  .check_input(train_win, "numeric")
  .check_length(train_break, 1)
  .check_input(train_break, "numeric")
  .check_type(type)
  data$score <- data[glue("score_{type}")][[1]]
  data <- group_by(data, .data$keyword, .data$control, .data$location)
  data <- mutate(data, base = rollmean(.data$score, k = train_win, align = "right", fill = NA))
  data <- mutate(data, base = lag(.data$base, n = train_break + 1))
  data <- mutate(data, score_abnorm = .data$score - .data$base)
  data <- mutate(data, quantile = percent_rank(.data$score_abnorm))
  data <- ungroup(data)
  data <- select(
    data,
    .data$keyword,
    .data$location,
    .data$date,
    .data$control,
    .data$object,
    .data$score,
    .data$score_abnorm,
    .data$quantile
  )
  class(data) <- c("abnorm_score", class(data))
  return(data)
}

#' @rdname get_abnorm_hist
#' @export

get_abnorm_hist.exp_voi <- function(data, train_win = 12, train_break = 0, type = "obs") {
  .check_length(train_win, 1)
  .check_input(train_win, "numeric")
  .check_length(train_break, 1)
  .check_input(train_break, "numeric")
  .check_type(type)
  data$voi <- data[glue("score_{type}")][[1]]
  data <- group_by(data, .data$keyword, .data$control)
  data <- mutate(data, base = rollmean(.data$voi, k = train_win, align = "right", fill = NA))
  data <- mutate(data, base = lag(.data$base, n = train_break + 1))
  data <- mutate(data, voi_abnorm = .data$voi - .data$base)
  data <- mutate(data, quantile = percent_rank(.data$voi_abnorm))
  data <- ungroup(data)
  data <- select(
    data,
    .data$keyword,
    .data$date,
    .data$control,
    .data$object,
    .data$voi,
    .data$voi_abnorm,
    .data$quantile
  )
  class(data) <- c("abnorm_voi", class(data))
  return(data)
}

#' @rdname get_abnorm_hist
#' @export

get_abnorm_hist.exp_doi <- function(data, train_win = 12, train_break = 0, measure = "gini") {
  .check_length(train_win, 1)
  .check_input(train_win, "numeric")
  .check_length(train_break, 1)
  .check_input(train_break, "numeric")
  .check_measure(measure)
  data$doi <- data[measure][[1]]
  data <- group_by(data, .data$keyword, .data$type, .data$control, .data$locations)
  data <- mutate(data, base = rollmean(.data$doi, k = train_win, align = "right", fill = NA))
  data <- mutate(data, base = lag(.data$base, n = train_break + 1))
  data <- mutate(data, doi_abnorm = .data$doi - .data$base)
  data <- mutate(data, quantile = percent_rank(.data$doi_abnorm))
  data <- ungroup(data)
  data <- select(
    data,
    .data$keyword,
    .data$date,
    .data$type,
    .data$control,
    .data$object,
    .data$locations,
    .data$doi,
    .data$doi_abnorm,
    .data$quantile
  )
  class(data) <- c("abnorm_doi", class(data))
  return(data)
}


source("computing_frequencies.r")
source("number_to_pattern.r")

faster_frequent_words <- function(text, k) {
  frequent_patterns <- {}
  frequency_array <- computing_frequencies(text, k)
  max_count <- max(frequency_array)
  for (i in 0:(4^k-1)) {
    if (frequency_array[i + 1] == max_count) {
      pattern <- number_to_pattern(i, k)
      frequent_patterns <- append(frequent_patterns, pattern)
    }
  }
  return(frequent_patterns)
}

message("Text")
text <- scan("stdin", what="character", nlines=1)
message("K")
k <- scan("stdin", nlines=1)

print(faster_frequent_words(text, k))


# Exercise 7: DPLYR practice with NBA data
library(dplyr)
# Read in the NBA player data into a variable called `team.data` using `read.csv`
setwd("C:\\Users\\sanja\\OneDrive - UW\\School\\Sophomore Year\\INFO 201\\ch10-dplyr\\exercise-7")
team.data <- read.csv(file="data//teams.csv")
# The data.frame team.data should now be accessible to you.
# View it, and get some basic information about the number of rows/columns.
# Note the "X" preceding some of the column titles as well as the "*"
# following the names of teams that made it to the playoffs that year.

# Add a column that gives the turnovers to steals ratio (TOV / STL) for each team
team.data <- mutate(team.data, Turnovers = TOV / STL)

# Sort the teams from lowest turnover/steal ratio to highest
# Which team has the lowest ratio?
team.data <- arrange(team.data, Turnovers)
## BOSTON CELTICS

# Using the pipe operator, create a new column of assists per game (AST / G) AND
# sort the data.frame by this new column in DESCENDING order.
team.data %>%
  mutate(APG = AST / G) %>%
  arrange(APG)
# Create a data.frame called `good.offense` of teams that scored more than 8700 points (PTS)
good.offense <- filter(team.data, PTS > 8700)
# Create a data.frame called `good.defense` of teams that had more than 470 blocks (BLK)
good.defense <- filter(team.data, BLK > 470)
# Create a data.frame called `defense.stats` that only shows defensive rebounds (DRB), steals (STL),
# and blocks (BLK) along with the team name.
defense.stats <- select(team.data, Team, DRB, STL, BLK)
# Create a data.frame called `offense.stats` that only shows offensive rebounds (ORB),
# field-goal % (FG.), and assists (AST) along with the team name.
offense.stats <- select(team.data, Team, ORB, FG, AST)
### Bonus ###
# Create a function called `BetterShooters` that takes in two teams and returns
# a data.frame of the team with the better field-goal percentage. The returned
# data.frame should include the team name, field-goal percentage, and points.
BetterShooters <- function(team1, team2) {

}


library(ggplot2)

setwd('/Users/dago/Documents/Courses/algorithms/A11')
data = read.csv('out.csv',sep=';')

data_t1 = data[data$tipo == 1, ]
data_t2 = data[data$tipo == 2, ]

par(mfrow=c(1,2))
hist(data_t1$key,probability = FALSE,ylim = c(0,9000),xlab ='Posición',ylab='Frecuencia',main = 'Módulo')
hist(data_t2$key,probability = FALSE,ylim = c(0,9000),xlab ='Posición',ylab='Frecuencia',main = 'Multiplicación')

agg = aggregate(data, by=list(data$repeticion,data$tipo), FUN=mean, na.rm=TRUE)
agg$tipo = as.factor(agg$tipo)

ggplot(data = agg, aes(y = colision, x = tipo)) + geom_boxplot() + theme_minimal()


library('meta')

# load all data
all_data <- read.csv('testsets/test_input.csv')

# get all outcomes
ocns = unique(all_data$outcome)

###########################################################
# Generate tests for OR fixed and random with MH/DL/nohak
###########################################################
# the final dataframe for output
df_rsts = data.frame()

# start count time
start_time <- Sys.time()

for (i in 1:length(ocns)) {
  ocn = ocns[i]
  df <- all_data[all_data$outcome == ocn, c('study', 'Et', 'Nt', 'Ec', 'Nc')]

  # get the result of this study
  r <- metabin(
    Et,
    Nt,
    Ec,
    Nc,
    data = df,
    studlab = study,
    sm = "OR",
    method = "MH",
    method.tau = "DL",
    prediction = FALSE,
    hakn = FALSE
  )

  df_rst = data.frame(
    "outcome" = c(paste(ocn)),
    "sm" = c('OR'),
    "TE.fixed" = c(r$TE.fixed),
    "lower.fixed" = c(r$lower.fixed),
    "upper.fixed" = c(r$upper.fixed),
    "TE.random" = c(r$TE.random),
    "lower.random" = c(r$lower.random),
    "upper.random" = c(r$upper.random),
    "I2" = c(r$I2),
    "tau2" = c(r$tau2),
    "pval.Q" = c(r$pval.Q)
  )

  # merge this record
  df_rsts = rbind(df_rsts, df_rst)

}
end_time <- Sys.time()
print(paste0('Spent: ', end_time - start_time, ' for OR fixed and random'))
# print(df_rsts)

write.csv(
  df_rsts,
  file='testsets/test_result_OR.csv',
  row.names = FALSE
)

###########################################################
# Generate tests for OR fixed and random with MH/DL/nohak
###########################################################
# the final dataframe for output
df_rsts = data.frame()

# start count time
start_time <- Sys.time()

for (i in 1:length(ocns)) {
  ocn = ocns[i]
  df <- all_data[all_data$outcome == ocn, c('study', 'Et', 'Nt', 'Ec', 'Nc')]

  # get the result of this study
  r <- metabin(
    Et,
    Nt,
    Ec,
    Nc,
    data = df,
    studlab = study,
    sm = "RR",
    method = "MH",
    method.tau = "DL",
    prediction = FALSE,
    hakn = FALSE
  )

  df_rst = data.frame(
    "outcome" = c(paste(ocn)),
    "sm" = c('RR'),
    "TE.fixed" = c(r$TE.fixed),
    "lower.fixed" = c(r$lower.fixed),
    "upper.fixed" = c(r$upper.fixed),
    "TE.random" = c(r$TE.random),
    "lower.random" = c(r$lower.random),
    "upper.random" = c(r$upper.random),
    "I2" = c(r$I2),
    "tau2" = c(r$tau2),
    "pval.Q" = c(r$pval.Q)
  )

  # merge this record
  df_rsts = rbind(df_rsts, df_rst)

}
end_time <- Sys.time()
print(paste0('Spent: ', end_time - start_time, ' for RR fixed and random'))
# print(df_rsts)

write.csv(
  df_rsts,
  file='testsets/test_result_RR.csv',
  row.names = FALSE
)

###########################################################
# Generate tests for INCD/PFT fixed and random with Inverse/DL/nohak
###########################################################
# the final dataframe for output
df_rsts = data.frame()

# start count time
start_time <- Sys.time()

for (i in 1:length(ocns)) {
  ocn = ocns[i]
  df <- all_data[all_data$outcome == ocn, c('study', 'Et', 'Nt', 'Ec', 'Nc')]

  # get the result of this study
  r <- metaprop(
    Et,
    Nt,
    data = df,
    studlab = study,
    sm = "PFT",
    method = "Inverse",
    method.tau = "DL",
    prediction = FALSE,
    hakn = FALSE
  )

  df_rst = data.frame(
    "outcome" = c(paste(ocn)),
    "sm" = c('PFT'),
    "TE.fixed" = c(r$TE.fixed),
    "lower.fixed" = c(r$lower.fixed),
    "upper.fixed" = c(r$upper.fixed),
    "TE.random" = c(r$TE.random),
    "lower.random" = c(r$lower.random),
    "upper.random" = c(r$upper.random),
    "I2" = c(r$I2),
    "tau2" = c(r$tau2),
    "pval.Q" = c(r$pval.Q)
  )

  # merge this record
  df_rsts = rbind(df_rsts, df_rst)

}
end_time <- Sys.time()
print(paste0('Spent: ', end_time - start_time, ' for PFT fixed and random'))
# print(df_rsts)

write.csv(
  df_rsts,
  file='testsets/test_result_PFT.csv',
  row.names = FALSE
)


force_cos_ramp_constraint_prefilled <- function(speed_limit, vector_out = c(28.8,0,0,0)) {
    return(force_cos_ramp_constraint(H_matrix = H_matrix, bounds_tuple_of_numeric = bounds_tuple_of_numeric,
    vector_out = vector_out, max_allowable_increasing_tension_speed=speed_limit, max_allowable_decreasing_tension_speed=speed_limit,
    n_task_values = 100, cycles_per_second = 60, cyclical_function = force_cos_ramp,
    eliminate = FALSE))
}
force_cos_ramp_is_feasible <- function(speed_limit, ...){
    tryCatch({
        big_constraint <- force_cos_ramp_constraint_prefilled(speed_limit=speed_limit, ...)
        c_is_feasible <- big_constraint$nonredundant_constr %>% constraint_is_feasible
        return(c_is_feasible)
    }, error = function(cond){
        print(cond)
        return(FALSE)
    })
}

har_dataframe_force_cos <- function(H_matrix,bounds_tuple_of_numeric,increasing,decreasing,n_task_values, har_n, vector_out){
    st_constr_str <- force_cos_ramp_constraint(H_matrix, bounds_tuple_of_numeric, vector_out, increasing,decreasing, n_task_values = n_task_values, cycles_per_second=10, eliminate = FALSE)
    param_string <- paste0("n_task_values:",n_task_values,"st increasing:", increasing, "decreasing:", decreasing)
    print('redundancies')
    res <- st_constr_str$nonredundant_constr %>% eliminate_redundant_single
    print('har')
    points <- res %>% har_sample(har_n, eliminate=FALSE)
    tall_df_st <- points %>% trajectory_har_df_melt(length(bounds_tuple_of_numeric))
    tall_df_st$st <- increasing
    return(tall_df_st)
}


# labeler function to create proper scientific notation
# philip kraaijenbrink

#' Clean scientific notation labeler
#'
#' Convert numbers into a scientific notation expression that uses \out{2.4 x 10-3} format
#' @param x Numeric vector.
#' @param ... Any other argument passed to \code{base::format()}
#'
#' @return Expression vector
#' @export
scientific10 <- function(x, ...){
  s         <- format(x,scientific=T,...)
  number    <- sapply(strsplit(s,'e'), function(x) x[1])
  expbit    <- as.character(as.integer(sapply(strsplit(s,'e'), function(x) x[2])))
  formatted <- parse(text=paste0(number,'%*%10^',expbit), keep.source=T)
  return(formatted)
}


#' Calculate position of linkage group on plot area
#'
#' @param plotSize Dimension (size) of x axis
#' @param count Number of linkage groups
#' @return positional coordinates
#' @importFrom utils head tail
#' @export
linkage.group.position <- function(plotSize = NULL, count = NULL) {
    if(is.null(plotSize)){
      stop("Size of plot is missing.")
    }
    if(is.null(count)){
      stop("Number of linkage groups missing.")
    }

    distance <- 80
    midpoint <- plotSize / 2
    offset <- 20
    lgsize <- 40

    position.left <- function(x) {
      posLeft <- head(seq(midpoint - (distance * x), midpoint, distance), n = -1)
      return(posLeft)
    }
    position.right <- function(x) {
      posRight <- tail(seq(midpoint, midpoint + (distance * x), distance), n = -1)
      return(posRight)
    }

    # if single linkage group is requested -> draw at midpoint (-offset)
    if (count == 1) {
      return(midpoint - offset)
    }
    # if count is even
    if ((count %% 2) == 0) {
      perGroup <- count / 2
      coordinates <- c(position.left(perGroup) + lgsize, position.right(perGroup) - lgsize) - offset
      return(coordinates)
    }
    # if count is odd
    else {
      perGroup <- (count - 1) / 2
      coordinates <- c(position.left(perGroup), midpoint, position.right(perGroup)) - offset
      return(coordinates)
    }
  }


library(sf)
library(ggplot2)
library(dplyr)

# consider the case when multiple inputs have the same name
# group: polygon group
# district: principal administrative divisions
get_df <- function(geodf)
{
  pointdf <- data.frame()
  for(i in 1:nrow(geodf))
  {
    tmp <- geodf[i,]$points[[1]]
    pointdf <-
      rbind(pointdf,
            lapply(1:length(tmp), FUN = function(x) data.frame(tmp[[x]][[1]], 1:nrow(tmp[[x]][[1]]),
                                                               paste0(geodf$ID[i], x), geodf$name[i])) %>%
              do.call(rbind,.) %>% "names<-"(c("long", "lat","order", "group", "district")))
  }
  return(pointdf)
}

ozbig <- read_sf("data/gadm36_AUS_shp/gadm36_AUS_1.shp")
oz <- thin(ozbig)

oz %>% transmute(ID = GID_1, points = geometry, name = NAME_1) %>%
  split(.$ID) %>% purrr::map(function(x) get_df(x)) %>%
  do.call(rbind, .) %>%
  ggplot(aes(x = long, y = lat, group = group, fill = district)) + geom_polygon() +
  scale_y_continuous(n.breaks = 5)  + theme_bw() + theme(legend.position = "none")


require(deSolve)

run.fsmm = function(fsmm.model.input  = read.csv("data/fsmm.example.forcing.vars.csv"),
                    fsmm.model.pars = c(4.98,-18.80,3.01e-10,0.768,0.22),
                    ## vector of model Pars, Order: A,B,K_s,M_MAX,DR_O
                    RHO_S = 400,
                    # kg m-3 : Stick density  (taken from Nelson, 2000))
                    r = 0.0065,
                    # radius of stick (m)
                    L = 0.41,
                    # length of stick (m)
                    m_i = 0.1,
                    CALC_SHAPE_FACTOR = T) {
  # initial moisture level

  ######################################################################
  ## Load in fortran code

  system('R CMD SHLIB -o fsmm.so code/fsmm.f ')
  dyn.load('fsmm.so')

  ######################################################################
  ## calculate area of shadow cast by stick
  ## from Monteith and Unsworth (2008) pg 105

  if (CALC_SHAPE_FACTOR) {
    fsmm.model.input$shape.factor <-
      ifelse(
        fsmm.model.input$Alt_s > 0,
        2 * r * L * (1 / sin(fsmm.model.input$Alt_s)) * sqrt(
          1 - cos(fsmm.model.input$Alt_s) ^ 2 * cos(fsmm.model.input$Azi_s) ^ 2
        ) + pi * r ^ 2 * (1 / tan(fsmm.model.input$Alt_s)) * cos(fsmm.model.input$Azi_s),
        0
      )

  } else {
    fsmm.model.input$shape.factor <- 1

  }

  ######################################################################
  ## Create Time variable (in seconds)

  time.out <- seq(1, nrow(fsmm.model.input) * 3600, 3600)

  ######################################################################
  ## Create Forcing Variables matrix

  forcing.variables <- list(
    matrix(
      ncol = 2,
      data = c(time.out, fsmm.model.input$k.down.dir)
    ),
    matrix(
      ncol = 2,
      data = c(time.out, fsmm.model.input$k.down.diff)
    ),
    matrix(
      ncol = 2,
      data = c(time.out, fsmm.model.input$shape.factor)
    ),
    matrix(
      ncol = 2,
      data = c(time.out, fsmm.model.input$temp)
    ),
    matrix(
      ncol = 2,
      data = c(time.out, fsmm.model.input$L_dn)
    ),
    matrix(
      ncol = 2,
      data = c(time.out, fsmm.model.input$rh)
    ),
    matrix(
      ncol = 2,
      data = c(time.out, fsmm.model.input$wind.speed)
    ),
    matrix(
      ncol = 2,
      data = c(time.out, fsmm.model.input$precip)
    )
  )

  ######################################################################
  ## Create state vector with initial values

  state <-
    c(
      fuel.temp.mod.core = head(fsmm.model.input$temp, 1),
      fuel.mois.mod.outer = m_i * (pi * r ^ 2 * L * RHO_S),
      fuel.mois.mod.core = m_i * (pi * r ^ 2 * L * RHO_S),
      fuel.temp.mod.core = head(fsmm.model.input$temp, 1)
    )

  ######################################################################
  ## Create parameter vector (this includes the radius and length of the stick)

  fsmm.model.pars.full <- c(fsmm.model.pars, r, L)

  ######################################################################
  ## Run Model. the output

  model.out <- ode(
    y = state,
    times = time.out,
    func = 'fmccore',
    parms = fsmm.model.pars.full,
    verbose = FALSE,
    ynames = TRUE,
    dllname = 'fsmm',
    initfunc = 'fmcpar',
    nout = 2,
    outnames = c("fuel.mois.mod", "fuel.temp.mod"),
    forcings = forcing.variables,
    initforc = 'fmcforc'
  )

}