library(StratTourn) library(xtable) library(ggplot2) library(reshape2) library(googleVis) library(dplyr) library(tidyr) library(lattice)
#setwd("D:/libraries/StratTourn") #setwd("D:/libraries/StratTourn/studies") setwd("E:/!Data/!Daten/Work/Promotion/L - Lectures/Kooperation Spieltheorie/WS 2015-16/StratTourn/studies") tourn = load.tournament("Tourn_hotelling_20151119_105852.tou") # Data for each match md = tourn$dt md = add.other.var(md,c("strat","u")) md$delta.u = md$u - md$other.u # Names of all strategies strats = unique(md$strat) rank.dt = strat.rank.from.matches(md) # Data for each round file = tourn$rs.file rd = fread(file) rd = as.tbl(as.data.frame(rd)) rd = add.other.var(rd,c("strat","u","s")) # Names of all strategies strats = unique(rd$strat) # Perhaps select a subset of strategies used.strats = strats ard = rd if (!identical(used.strats,strats)) { rows = rd$strat %in% used.strats & rd$other.strat %in% used.strats rd = ard[rows,] }
end.t = 10 start.t = 1 resolution = 20
rd = add.other.var(rd,c("strat","p","l")) rd = filter(rd, t %in% start.t:end.t) #Timeframe rep.params <- tourn$game$params #which customers are served? bucket.n = resolution coverage <- function(p1,l1,p2,l2, rep.params, n=bucket.n){ restore.point("coverage") lb <- rep.params$lower.bound ub <- rep.params$upper.bound s <- rep.params$s t <- rep.params$t.distance range <- seq(lb,ub,length.out=n+1) range.length <- range[2]-range[1] #Calculate ranges x.lower1 <- l1 + (p1-s)/t x.lower2 <- l2 + (p2-s)/t x.upper1 <- l1 + (s-p1)/t x.upper2 <- l2 + (s-p2)/t res <- sapply(1:n, FUN=function(i){ if(x.lower1<=range[i] && x.upper1>=range[i+1]){ res1 <- 1 } else if (x.lower1<=range[i] && x.upper1<=range[i]){ res1 <- 0 } else if (x.lower1>=range[i] && x.upper1>=range[i]){ res1 <- 0 } else if (x.lower1<=range[i] && x.upper1<range[i+1]){ res1 <- (x.upper1-range[i])/range.length } else if (x.lower1>range[i] && x.upper1>=range[i+1]){ res1 <- (range[i+1]-x.lower1)/range.length } else if (x.lower1>range[i] && x.upper1<range[i+1]){ res1 <- (x.upper1-x.lower1)/range.length } else { #should never happen res1 <- 0 } if(x.lower2<=range[i] && x.upper2>=range[i+1]){ res2 <- 1 } else if (x.lower2<=range[i] && x.upper2<=range[i]){ res2 <- 0 } else if (x.lower2>=range[i] && x.upper2>=range[i]){ res2 <- 0 } else if (x.lower2<=range[i] && x.upper2<range[i+1]){ res2 <- (x.upper2-range[i])/range.length } else if (x.lower2>range[i] && x.upper2>=range[i+1]){ res2 <- (range[i+1]-x.lower2)/range.length } else if (x.lower2>range[i] && x.upper2<range[i+1]){ res2 <- (x.upper2-x.lower2)/range.length } else { #should never happen res2 <- 0 } res <- max(res1,res2) }) return(res) } cov.df <- matrix(sapply(1:nrow(rd),simplify=TRUE,FUN=function(x){ coverage(p1=rd$p[x],l1=rd$l[x],p2=rd$other.p[x],l2=rd$other.l[x],rep.params=rep.params) }), nrow=nrow(rd), byrow=TRUE) lb <- rep.params$lower.bound ub <- rep.params$upper.bound range <- seq(lb,ub,length.out=bucket.n+1) start.val <- range[1] end.val <- range[length(range)-1] colnames(cov.df) <- range[-length(range)] start <- colnames(cov.df)[1] end <- colnames(cov.df)[ncol(cov.df)] offset <- ncol(rd) rd <- cbind(rd, cov.df) rdt = group_by(gather(rd,type,value,(offset+1):(ncol(rd))), strat, other.strat, t, type) sd <- summarise(rdt, coverage=mean(value)) sd$type[sd$type==start] <- start.val sd$type[sd$type==end] <- end.val sd$type <- as.numeric(sd$type) rank.strats = rank.dt$strat sd$strat = factor(sd$strat, rank.strats, ordered=TRUE) sd$other.strat = factor(sd$other.strat, rank.strats, ordered=TRUE)
levelplot(coverage~t*type|other.strat+strat, sd,col.regions=heat.colors(1000), cuts=1000-1, xlab="t", ylab="coverage") #levelplot(coverage~t*type, sd,col.regions=heat.colors(1000), cuts=1000-1, xlab="t", ylab="coverage") cat("\n")
The plot shows to which percentage the customers choose to buy from either firm on average given the period.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.