Skip to content
Snippets Groups Projects
Commit 60593eb3 authored by pbac's avatar pbac
Browse files

added prbsTforward-1

parent b5073dab
No related branches found
No related tags found
No related merge requests found
This diff is collapsed.
---
title: "prbs-Tforward-1"
output:
# pdf_document:
# fig_caption: yes
# fig_crop: FALSE
html_document:
toc: true
toc_float: true
---
```{r setup, include=FALSE, cache=FALSE, purl=FALSE}
knitr::opts_chunk$set(echo = TRUE, results = 'hide', message = FALSE, warning = FALSE, fig.height = 4, fig.width = 14, fig.path = 'genfig/', cache.path = 'cache/', cache = TRUE, cache.rebuild = TRUE, dpi=100)
```
```{r init, echo=FALSE, cache=FALSE}
##----------------------------------------------------------------
## Set the working directory
setwd(".")
## Source the files in the "functions" folder
files <- dir("functions",full.names=TRUE)
for(i in 1:length(files)) source(files[i])
##----------------------------------------------------------------
```
# Introduction {.tabset}
In this experiment the forward temperature set point of the building heating is controlled to follow a Pseudo Random Binary Sequence (PRBS). This enables a controlled experiment where the control variable will be set independently (uncorrelated) to other variables (like time of day, external temperature, etc.).
For an explanaition of the PRBS, see prbs-multiroom-1 description.
## PRBS with different levels
Combine periods with different temperature levels.
```{r prbsplotts2}
## Create sequence
testseq <- function(n, lambda, nhours, starthour, Tmin, Tmax, plotit=TRUE){
x <- prbs(n, 42, lambda)
t1 <- starthour + ((1:length(x))[abs(c(0,diff(x)))==1] / length(x)) * nhours
## Round to 5 min steps
t1 <- round(t1*12) / 12
val1 <- rep(c(Tmin,Tmax), length(t1))[1:length(t1)]
##
if(plotit){ plot(t1, val1, type="s") }
##
return(data.frame(t=t1, Tset=val1))
}
## val <- testseq(n=5, lambda=1, nhours=96, Tmin=15, Tmax=24)
## diff(val$t)
## Four days between 20 and 65 degrees C
val1 <- testseq(n=5, lambda=1, nhours=96, starthour=0, Tmin=20, Tmax=65, plotit=FALSE)
## Two days between 30 and 60 degrees C
val2 <- testseq(n=5, lambda=1, nhours=48, starthour=96, Tmin=30, Tmax=60, plotit=FALSE)
## Two days between 40 and 55 degrees C
val3 <- testseq(n=5, lambda=2, nhours=48, starthour=96+48, Tmin=40, Tmax=55, plotit=FALSE)
## Two day between 45 and 50 degrees C
val4 <- testseq(n=5, lambda=1, nhours=24, starthour=96+48+48, Tmin=45, Tmax=50, plotit=FALSE)
## Combined
X <- rbind(val1, val2, val3, val4)
names(X)[2] <- "Tforward"
plot(X$t/24, X$Tset, type="s")
```
## Constant room temperature set points
If room temperature set points can be set, they should be set to a "default" fixed level
```{r}
nms <- read.table("../data/outchannels.csv", header=TRUE, sep=",", as.is=TRUE)$ResampleVarname
nmsRooms <- nms[grep("^Room_C", nms)]
Xrooms <- cbind.data.frame(t=0, sapply(nmsRooms, function(nm){20}, simplify=FALSE))
```
## Write to a files
```{r write-to-files, cache=FALSE}
## Set starting date and time in hours
X$t <- asp("2019-04-13 00:00") + X$t * 3600
##
dir.create("outchannels", showWarnings = FALSE)
file.remove(dir("outchannels/", full.names=TRUE))
## Write to a .csv files
write.table(X, file=pst("outchannels/Room_VVX02_SpTF01.csv"), sep=",", row.names=FALSE)
## Room temperature setpoints
for(i in 2:ncol(Xrooms)){
write.table(Xrooms[c(1,i)], file=pst("outchannels/",names(Xrooms)[i],".csv"), sep=",", col.names=c("t","Tset"), row.names=FALSE)
}
```
```{r write-the-R-code, purl=FALSE}
##library(knitr)
##purl("experiment.Rmd")
```
```{r move-output-file, purl=FALSE, cache=FALSE}
file.copy("experiment.html","../prbs-Tforward-1.html")
```
\ No newline at end of file
This diff is collapsed.
## Define a generic method
asp <- function(object, ...){
UseMethod("asp")
}
asp.default <- function(object){
return(object)
}
asp.character <- function(object, tz = "GMT", ...){
as.POSIXct(object, tz = tz, ...)
}
asp.POSIXct <- function(object){
object
}
asp.POSIXlt <- function(object){
as.POSIXct(object)
}
asp.numeric <- function(object){
ISOdate(1970, 1, 1, 0) + object
}
nams <- function(x) {
if(is.matrix(x)){
colnames(x)
} else {
names(x)
}
}
`nams<-` <- function(x, value) {
if(is.matrix(x)){
colnames(x) <- value
} else {
names(x) <- value
}
x
}
## Define a generic method
plot_ts <- function(object, ...){
UseMethod("plot_ts")
}
plot_ts.data.list <- function(object, patterns, tstart = NA, tend = NA, kseq = 0, colorpalette = NA, ...) {
DL <- object
## Plot it for a period
oldpar <- setpar("ts")
on.exit(par(oldpar))
##
if(is.na(tstart)) { tstart <- DL$t[1] - 1 }
if(is.na(tend)) { tend <- DL$t[length(DL$t)] }
DL <- subset(DL, period(tstart, DL$t, tend))
##
## Generate a data.frame with the series to be plotted
X <- lapply_cbind_df(patterns, function(pattern) {
## Find the columns to plot
nms <- grep(pattern, names(DL), value = TRUE)
if(length(nms) == 0){
warning(pst("No names where found matching: ", pattern))
tmp <- as.data.frame(matrix(NA,nrow=length(DL$t),ncol=1))
names(tmp)[1] <- pattern
return(tmp)
}else{
## Do the plotting
do.call("cbind", lapply(nms, function(nm){
if(is.null(dim(DL[[nm]]))) {
## It is a vector
X <- data.frame(DL[[nm]])
names(X) <- nm
return(X)
} else {
## Its a matrix
## Find the columns with k and digits
i <- grep("^k[[:digit:]]+$", nams(DL[[nm]]))
if(length(i) > 0) {
## Try to return the kseq forecast columns
ik <- which(pst("k",kseq) %in% nams(DL[[nm]]))
X <- lag(DL[[nm]][ ,pst("k",kseq[ik])], lag = kseq[ik])
if(is.null(dim(X))) {
X <- as.data.frame(X)
names(X) <- pst("k",kseq)
}
} else {
## Just return all
X <- DL[[nm]]
}
nams(X) <- pst(nm, "_", nams(X))
return(X)
}
}))
}
})
if(any(duplicated(nams(X)))){
X <- X[ ,unique(nams(X))]
}
X$t <- DL$t
## Use the plot_ts function which takes the data.frame
nms <- unlist(getse(strsplit(nams(X), "_k"), 1))
plot_ts.data.frame(X, patterns, colorpalette = colorpalette, nms = nms, ...)
}
## Plot all with prefix
plot_ts.data.frame <- function(object, patterns, xnm = "t", draw_grid = TRUE, xlabs = NA, ylabs = NA,
space_for_legend = 0.25, cex.legend = 1, xaxis_format = NA, colorpalette = NA,
ylim = NA, main = "", nms = NA, xat = NA, xnticks = 8, ...) {
##
data <- object
patterns <- patterns[patterns != xnm]
##
oldpar <- setpar("ts", mfrow = c(length(patterns), 1))
on.exit(par(oldpar))
##
for (i in 1:length(patterns)) {
if (is.na(ylim[1])) {
ylim <- NA
} else {
ylim <- ylim[[i]]
}
if (class(colorpalette) == "list") {
colorpalette <- colorpalette[[i]]
}
##
plot_ts_series(data, patterns[i], draw_grid, xnm, space_for_legend = space_for_legend,
cex.legend = cex.legend, colorpalette, ylim, main[i], nms = nms, ...)
if (!is.na(ylabs[1]))
title(ylab = ylabs[i], yaxt = "s")
}
if (any(nams(data) == xnm)) {
if (class(data[ ,xnm])[1] == "numeric") {
axis(1, data[ ,xnm], xaxt = "s")
} else {
## makes too few ticks: axis.POSIXct(1, data[ ,xnm], format = xaxis_format, xaxt = "s")
if(is.na(xat[1])){ xat <- pretty(data[ ,xnm]) }
if(is.na(xaxis_format)){
if( all(as.numeric(xat,unit="secs") %% (24*3600) == 0) ){
xaxis_format <- "%Y-%m-%d"
}else{
xaxis_format <- "%Y-%m-%d %H:%M"
}
}
axis.POSIXct(1, data[ ,xnm], at = xat, format = xaxis_format, xaxt = "s")
}
} else {
axis(1, 1:nrow(data), xaxt = "s")
}
}
plot_ts.matrix <- plot_ts.data.frame
## Plot all columns found with regex pattern
plot_ts_series <- function(data, pattern, draw_grid, xnm, space_for_legend = 0.25, cex.legend = 1,
colorpalette = NA, ylim = NA, main = "", nms = NA, ...) {
## Use these names when finding columns to plot
if(is.na(nms[1])) {
nms <- nams(data)
}
iseq <- integer(0)
for (pf in strsplit(pattern, "\\|")[[1]]) {
iseq <- c(iseq, grep(pf, nms))
}
## Check if xnm is in the data
if (any(nms == xnm)) {
##iseq <- iseq[-which(nms[iseq] == xnm)]
x <- data[, xnm]
} else {
x <- 1:nrow(data)
}
## Limits on y-axis
if (is.na(ylim[1])) {
ylim <- range(data[, iseq], na.rm = TRUE)
}
##
if (any(is.infinite(ylim))){
## If no values then plot empty
plot(x, x, type = "n")
legend("topright", paste0(nams(data)[iseq], ": NA"))
} else {
plot(x, x, type = "n", xlim = c(min(x), max(x) +
diff(range(x)) * space_for_legend), ylim = ylim, yaxt = "n", bty = "n",
xlab = "", ylab = "", ...)
yat <- pretty(scalerange(data[, iseq], 0.2))
axis(2, yat)
## Grid
if(draw_grid){
abline(v = pretty(x), h = yat, col = "grey85", lty = 2)
}
box()
##
if (is.na(colorpalette[1])) {
colorramp <- colorRampPalette(c("black","cyan","purple","blue","red","green"))
##colorRampPalette(c("#00007F", "blue", "#007FFF", "cyan",
## "#7FFF7F", "yellow", "#FF7F00", "red", "#7F0000"))
} else {
colorramp <- colorRampPalette(colorpalette)
}
##
colormap <- colorramp(length(iseq))
for (i in 1:length(iseq)) {
lines(x, data[, iseq[i]], col = colormap[i], ...)
}
rng <- do.call("rbind", lapply(1:length(iseq), function(i) {
paste(format(range(data[, iseq[i]], na.rm = TRUE), digits = 2), collapse = " to ")
}))
legend("topright", paste0(nams(data)[iseq], ": ", rng), lty = 1, col = colormap,
cex = cex.legend, bg="white", ...)
}
title(main = main, line = -1)
invisible(iseq)
}
## DL <- list(x=10:1, Y=data.frame(k1=c(1:10),k2=c(11:20)))
## class(DL) <- "data.list"
## plot_ts(DL)
## Plot ts with ggplot2
## ## Plot all with prefix plotmultigg <-
## function(X,patterns,grid_delta_t=NA,xlabs=NA,ylabs=NA,...) { ## Plot
## require('ggplot2') require('reshape2') require('gridExtra')
## ## Multiple with same y-axis ## Get the data to plot
## length(patterns)
## for(i in 1:length(patterns)) { ## Melt the data to plot, with 't' and the
## columns tmp <- melt(X[ ,c('t',grep(patterns[i],nams(X)))], 't')
## X <- Xplot() ## Only the selected boxes X <- X[X$id %in% selectedBoxIds(), ] ##
## Lplot <- list() i <- 0 for(var in input$vars){ ## tmp <- X[X$variable==var, ]
## if(nrow(tmp)>0){ ## By color i <- i + 1 Lplot[[i]] <- ggplot(tmp, aes(x=t,
## y=value, color=id)) + labs(title=var) + geom_line() } } ml <-
## marrangeGrob(Lplot, nrow=5, ncol=1, top='') print(ml)
## setpar('ts',mfrow=c(length(patterns),1)) for(i in 1:length(patterns)) {
## plotseries(X,patterns[i],grid_delta_t,...) if(!is.na(ylabs[1])) title(ylab=ylabs[i],
## yaxt='s') } axis.POSIXct(1, X$t,format=c('%m-%d %H:%M'), xaxt='s') }
prbs <- function(n, initReg=666, lambda=1)
{
## Function for generating PRBS sequences.
## - n is the length of the register
## - initReg just needs to be some initial value of 1,2,...
## it is the initial value of the registers and therefore only
## determines the start of the cycle
## - lambda is the length of the smallest period in
## which the signal can change, given in samples
##
## Check the input
if(n < 2 | n > 11){ stop("n must be between 1 and 11") }
## Do init
reg <- intToBits(as.integer(initReg))
print(reg)
x <- vector()
N <- 2^n - 1
## Do the shift according to the value of n
for(i in 1:N)
{
## Make the xor operation according to Godfrey80
if(n <= 4 | n == 6){ reg[n+1] <- xor(reg[1],reg[2]) }
else if(n == 5 | n == 11){ reg[n+1] <- xor(reg[1],reg[3]) }
else if(n == 7 | n == 10){ reg[n+1] <- xor(reg[1],reg[4]) }
else if(n == 8){ reg[n+1] <- as.raw(sum(as.integer(c(reg[1],reg[5],reg[6],reg[7])))%%2) }
else if(n == 9){ reg[n+1] <- xor(reg[1],reg[5]) }
## Keep the value of the first position in the register
x[i] <- as.integer(reg[1])
## Shift the register
reg[1:n] <- reg[2:(n+1)]
}
## Return x with each element repeated lambda times
rep(x, rep(lambda,N))
}
## Paste helper functions
pst <- function(...) {
paste0(...)
}
setpar <- function(tmpl = NA, ...) {
## Get par list
p <- par(no.readonly = TRUE)
## Templates
if (!is.na(tmpl)) {
if (tmpl == "ts") {
par(mfrow = c(3, 1), oma = c(3, 0, 2, 2), mar = c(0, 4, 0.5, 0), xaxt = "n",
mgp = c(2.2, 0.4, 0), tcl = -0.4)
}
if (tmpl == "pdf") {
par(mar = c(4, 4, 1, 1), mgp = c(2.2, 0.7, 0), tcl = -0.4)
}
}
## Replace all the parameters given in prm Get only the ... parameters
i <- which(!nams(match.call()) %in% nams(match.call(expand.dots = FALSE)))
if (length(i) > 0) {
par(...)
## prm <- as.list(match.call()[i]) p <- list() for(i in 1:length(prm)) { p$new <-
## eval(prm[[i]]) nams(p)[i] <- nams(prm)[i] } par(p)
}
## Set par and return the original par options(warn = (-1)) options(warn = 1)
invisible(p)
}
This diff is collapsed.
---
title: "prbs-multiroom-experiment1"
output:
# pdf_document:
# fig_caption: yes
# fig_crop: FALSE
html_document:
toc: true
toc_float: true
---
```{r setup, include=FALSE, cache=FALSE, purl=FALSE}
knitr::opts_chunk$set(echo = TRUE, results = 'hide', message = FALSE, warning = FALSE, fig.height = 4, fig.width = 14, fig.path = 'genfig/', cache.path = 'cache/', cache = TRUE, cache.rebuild = FALSE, dpi=100)
knitr::opts_chunk$set(echo = TRUE, results = 'hide', message = FALSE, warning = FALSE, fig.height = 4, fig.width = 14, fig.path = 'genfig/', cache.path = 'cache/', cache = TRUE, cache.rebuild = TRUE, dpi=100)
```
```{r init, echo=FALSE, cache=FALSE}
......@@ -200,3 +203,7 @@ lapply(1:length(L), function(i){
##library(knitr)
##purl("experiment.Rmd")
```
```{r move-output-file, purl=FALSE}
file.copy("experiment.html","../prbs-multiroom-experiment1.html")
```
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment