Polish versions of the scripts

Karol Niewiadomski
1 parent 5597cf6c
Showing 6 changed files with 455 additions and 18 deletions Show diff stats
.DS_Store
R/.DS_Store
R/SimulationsSwitchingsFun.R
R/StrukturaPlikow.R
R/hello.R
R/readingFuns.R
@@ -0,0 +1,129 @@
+#' Interference values
+#'
+#' Simulation of interference values at times t. Using the simple formula derived
+#' analytically. 
+#' 
+#' @param t numerical vector
+#' @param pc 1/switching frequency
+#' @param duty duty cycle
+#' @param t0 a numerical vector of initial starts ( assumed to be U(-pc, 0) )
+#'
+#' @return a numerical vector of values of interference at times t
+#' @export
+#'
+#' @examples
+Simulation <- function(t, pc, duty, t0, Np, A, f, lambda) {
+  
+  ii <- (seq_len(Np) - 1) * pc
+  
+  # Calculated parameters.
+  A1 <- purrr::map_dbl(t0, function(.t0) sum( cos(2 * pi * f * (ii - .t0)) * exp(-lambda * (ii - .t0)) ))
+  B1 <- purrr::map_dbl(t0, function(.t0) sum( sin(2 * pi * f * (ii - .t0)) * exp(-lambda * (ii - .t0)) ))
+  A2 <- purrr::map_dbl(t0, function(.t0) sum( cos(2 * pi * f * (ii - duty * pc - .t0)) * exp(-lambda * (ii - duty * pc - .t0)) ))
+  B2 <- purrr::map_dbl(t0, function(.t0) sum( sin(2 * pi * f * (ii - duty * pc - .t0)) * exp(-lambda * (ii - duty * pc - .t0)) ))
+  
+  
+  
+  y <- vector(mode = "numeric", length = length(t))
+  for(nk in seq_along(t0)) {
+    # From the reduced equation
+    t1 <- t - floor((t - t0[nk]) / pc) * pc
+    t2 <- t - floor((t - duty * pc - t0[nk]) / pc) * pc
+    C1 <- A * exp(-lambda * (t1))
+    C2 <- A * exp(-lambda * (t2))
+    f1 <- C1 * (A1[nk] * sin(2 * pi * f * (t1)) + B1[nk] * cos(2 * pi * f * (t1)))
+    f2 <- C2 * (A2[nk] * sin(2 * pi * f * (t2)) + B2[nk] * cos(2 * pi * f * (t2)))
+    y <- y + f1 - f2
+  }
+  return(y)
+}
+
+# Assuming that t0 depicts the only the moments before the first bit sent.
+SimulationNormal <- function(t, pc, duty, t0, Np, FunInter) {
+  
+  t1 <- purrr::map(t0, function(.t1) .t1 + seq(-2 * Np - 1, ceiling(max(t) / pc)) * pc)
+  t1 <- sort(purr::flatten_dbl(t1))
+  
+  KierWsp <- c("+" = 1, "-" = -1)
+  KierV <- c("+" = 0, "-" = 1)
+  
+  y <- vector(mode = "numeric", length = length(t)) 
+  for(.t1 in t1) {
+    for(kier in c("+", "-")) {
+      y <- y + KierWsp[kier] * FunInter(t - .t1 - KierV[kier] * duty * pc)
+    }
+  }
+  return(y)
+  
+  
+}
+
+
+
+#' Instead of looping through switching instants, loop is over t
+#' Since I want to check randomly chosen t for the error checking purpose.
+SimulationNormalTimes <- function(t, pc, duty, t0, Np, FunInter) {
+  
+  # max(t) may induce a lot of switching instants
+  t1 <- purrr::map(t0, function(.t1) .t1 + seq(-2 * Np - 1, ceiling(max(t) / pc)) * pc)
+  t1 <-sort(flatten_dbl(t1))
+  
+  KierWsp <- c("+" = 1, "-" = -1)
+  KierV <- c("+" = 0, "-" = 1)
+  
+  y <- vector(mode = "numeric", length = length(t))
+  i <- 1
+  for(.t in t) {
+    # print(i)
+    for(kier in c("+", "-")) {
+      y[i] <- y[i] + sum(KierWsp[kier] * FunInter(.t - t1 - KierV[kier] * duty * pc))
+    }
+    i <- i + 1
+  }
+  return(y)
+  
+  
+}
+
+
+#' Simulation to check, if error comes from N_p selected values or from the equations.
+#' 
+#' 
+SimulationNormalTimesNp <- function(t, pc, duty, t0, Np, FunInter) {
+  
+  # max(t) may induce a lot of switching instants
+  # NN <- length(t0)
+  t1 <- purrr::map(t0, function(.t1) .t1 + seq(-2 * Np - 1, ceiling(max(t) / pc)) * pc)
+  t1 <- sort(flatten_dbl(t1))
+  
+  KierWsp <- c("+" = 1, "-" = -1)
+  KierV <- c("+" = 0, "-" = 1)
+  
+  y <- vector(mode = "numeric", length = length(t))
+  i <- 1
+  for(.t in t) {
+    for(kier in c("+", "-")) {
+      # Take only the last Np values.
+      .t1 <- t1[ (t1 + KierV[kier] * duty * pc)  < .t & (t1 + KierV[kier] * duty * pc) >= .t - Np * pc] + KierV[kier] * duty * pc
+      # cat("Length .t1:", length(.t1), "-  NN * Np:", NN * Np, "\n")
+      y[i] <- y[i] + sum(KierWsp[kier] * FunInter(.t - .t1))
+    }
+    i <- i + 1
+  }
+  return(y)
+  
+}
+
+
+
+NpFun <- function(tol, A, lambda, pc) {
+  ceiling( (log(A) - log(tol)) / (lambda * pc) )
+}
+
+
+sqwave <- function(t, t_on, duty, pc) {
+  yy <- rep(c(1, 0), times = length(t_on))
+  tt <- sort(c(t_on, t_on + duty * pc))
+  f1 <- approxfun(tt, yy, method = "constant")
+  return(f1(t))
+}
 \ No newline at end of file
@@ -0,0 +1,183 @@
+#' Żeby moje symulacje miały jakikolwiek sens, chciałbym stworzyć strukturę
+#' porządkująca te symulacje. Tym sposobem, nie będę zawsze musiał się zastanawiać
+#' we jaki sposób porzadkować pliki.
+#' Moim celem jest, żeby stworzyć tabelę, w której trzymane będą parametry
+#' oraz nazwa pliku, w którym symulacje z danymi parametrami będą przechowywane.
+#'
+#' Chodzi również o to, żeby tę tabelę można było w prosty sposób uaktualniać dodając
+#' nowe wiersze, jeśliby doszły nowe pliki.
+#'
+#' Tabela powinna mieć także kolumnę ze wskaźnikiem na wersję (w przypadku
+#' powtórzenia symulacji z tymi samymi parametrami) oraz komentarz, jeśli
+#' jest jakiś potrzebny.
+#'
+library(tidyverse)
+library(feather)
+
+# Struktura ----
+struktura <- tibble(
+
+  # nazwa pliku
+  plik = character(),
+
+  # nazwa pliku z zawartymi oryginalnymi przesunięciami t0
+  plik_t0 = character(),
+
+  # wersja symulacji
+  version = integer(),
+
+  # częstotliwość transmisji danych
+  fd = numeric(),
+
+  # dt = 1 / fd
+  dt = numeric(),
+
+  # częstotliwość włączania konwerterów.
+  fc = numeric(),
+
+  # odległość pomiędzy kolejnymi włączeniami (pc = 1/fc)
+  pc = numeric(),
+
+  # duty cycle
+  duty = numeric(),
+
+  # liczba konwerterów
+  NK = integer(),
+
+  # liczba rund (powtórzeń symulacji)
+  rounds = integer(),
+
+  # liczba bitów w ramce
+  N = integer(),
+
+  # Parametry interferencji
+  # częstotliwość interferencji
+  f = numeric(),
+
+  # amplituda
+  A = numeric(),
+
+  # parametr tłumienia
+  lambda = numeric(),
+
+  # liczba okresów pc trwania sygnału
+  Np = integer(),
+
+  # tolerancja dla trwania sygnału
+  tol = numeric()
+
+
+)
+
+# write_feather(struktura, "Results/struktura.feather")
+
+
+# base_folder <- "/Volumes/Macbook Pro HDD /Doktorat/SCENT/Simulations/" 
+base_folder <- "/Users/karolniewiadomski/Documents/SCENT/Simulations/" 
+
+# Funkcje do czytania plików ----
+read_structure <- function() {
+  feather::read_feather(file.path(base_folder, "Results/struktura.feather"))
+}
+
+
+write_structure <- function(base_folder, new_structure) {
+  confirmation <- readline(prompt = "Do you really want to rewrite the current structure table? (y/n)")
+  if(confirmation == 'y') {
+    feather::write_feather(new_structure, file.path(base_folder, 'Results/struktura.feather')) 
+  }
+}
+
+#' TODO: make checks whenever possible, 
+#' especially check for the current rows to already exist.
+update_structure <- function(updated) {
+  old_structure <- feather::read_feather(file.path(base_folder, "Results/struktura.feather"))
+  old_classes <- map(old_structure, class)
+  new_classes <- map(updated, class)
+  
+  classes_equal <- all.equal(old_classes, new_classes)
+  
+  if (class(classes_equal) == "logical") {
+    if (classes_equal) {
+      new_structure <- bind_rows(old_structure, updated)
+      feather::write_feather(new_structure, file.path(base_folder, "Results/struktura.feather"))
+    }
+  } else {
+    stop("Something is missing, check classes of your file.")
+  }
+}
+
+
+
+
+
+
+#' TODO: check if it is possible not to read everytime.
+get_structure_classes <- function() {
+  x <- feather::read_feather(file.path(base_folder, "Results/struktura.feather"))
+  map(x, class)
+}
+
+
+
+
+
+
+# Assuming that names are not mixed up.
+repair_classes <- function(new_structure) {
+  removes <- list("integer" = as.integer, "character" = as.character, "numeric" = as.numeric)
+  classes <- get_structure_classes()
+  nms <- names(new_structure)
+  for( i in seq(1, length(new_structure))) {
+    
+    new_structure[, i] <- mutate_all(new_structure[, i], removes[[classes[[nms[i]]]]])
+  }
+  return(new_structure)
+}
+
+
+
+
+# Example of usage
+# new_structure <- list("cos", 1, 123, 1 / 123, 12, 1/234, 0.5, 4, 100, 4)
+# names(new_structure) <- names(read_structure())
+# new_structure <- as_tibble(new_structure)
+# classes <- get_structure_classes()
+# 
+# nms <- names(new_structure)
+# for( i in seq(1, length(new_structure))) {
+#   class(new_structure[, i]) <- classes[[nms[i]]]
+# }
+# 
+# update_structure(new_structure)
+
+
+create_file_name <- function(NK, fc, fd, t0 = FALSE, ext = ".rds") {
+  fc <- format(fc, scientific = FALSE)
+  fd <- format(fd, scientific = FALSE)
+  if (t0) {
+    return(stringr::str_interp("nk_$[.3d]{NK}_fc_${fc}_fd_${fd}_t0${ext}") )
+  } else {
+    return(stringr::str_interp("nk_$[.3d]{NK}_fc_${fc}_fd_${fd}${ext}"))
+  }
+}
+
+# it is not very quick. - could work on that a bit more.
+convert_file_name <- function(filename) {
+  # Could do with str_exctract_all but this is safer.
+  nk <- str_extract(filename, "nk_([:digit:]+)")
+  fc <- str_extract(filename, "fc_([:digit:]+)")
+  fd <- str_extract(filename, "fd_([:digit:]+)")
+  all_nums <- map(c(nk, fc, fd), function(x) parse_number(str_extract(x, "([:digit:]+)")) )
+  names(all_nums) <- c("NK", "fc", "fd")
+  return(all_nums)
+}
+
+
+
+
+
+
+
+
+
@@ -1,18 +0,0 @@
-# Hello, world!
-#
-# This is an example function named 'hello' 
-# which prints 'Hello, world!'.
-#
-# You can learn more about package authoring with RStudio at:
-#
-#   http://r-pkgs.had.co.nz/
-#
-# Some useful keyboard shortcuts for package authoring:
-#
-#   Install Package:           'Cmd + Shift + B'
-#   Check Package:             'Cmd + Shift + E'
-#   Test Package:              'Cmd + Shift + T'
-
-hello <- function() {
-  print("Hello, world!")
-}
@@ -0,0 +1,143 @@
+source("StrukturaPlikow.R")
+TF <- read_structure()
+
+read_nk <- function(.version = 6, nk, .type = "odl") {
+  # Weźmy konkretną częstotliwość.
+  TF <- TF %>% filter(version == .version)
+  # TF <- TF %>% filter(fc == 20000)
+  TF <- TF %>% filter(NK == nk)
+  V_th <- 3
+  
+  TD <- tibble()
+  for(i in seq_len(nrow(TF))) {
+    obj <- TF[i, ]
+    filename <- obj$plik
+    V <- read_rds(filename)
+    T2 <- map_dfr(V, function(syg) {
+      syg <- unlist(syg)
+      rley <- rle(abs(syg) >= V_th)
+      les <- rley$lengths
+      les <- les[-c(1, length(les))]
+      vals <- rley$values
+      vals <- vals[-c(1, length(vals))]
+      
+      if( .type == "zak" ) {
+        return(
+          with(obj, 
+               tibble(
+                 NK = NK,
+                 pc = pc, fc = fc,
+                 fd = fd, dt = dt,
+                 A = A, f = f, lambda = lambda, 
+                 type = "zak", value = les[vals], N = N
+               ))
+        )
+      } else if( .type == "odl" ) {
+        return(
+          with(obj, 
+          tibble(
+            NK = NK,
+            pc = pc, fc = fc,
+            fd = fd, dt = dt,
+            A = A, f = f, lambda = lambda, 
+            type = "odl", value = les[!vals], N = N 
+          ))
+        )
+      } else if( .type == "both" ) {
+        return(
+          with(obj, bind_rows(
+            tibble(
+              NK = NK,
+              pc = pc, fc = fc,
+              fd = fd, dt = dt,
+              A = A, f = f, lambda = lambda, 
+              type = "zak", value = les[vals], N = N
+            ),
+            tibble(
+              NK = NK,
+              pc = pc, fc = fc,
+              fd = fd, dt = dt,
+              A = A, f = f, lambda = lambda, 
+              type = "odl", value = les[!vals], N = N 
+            )
+          ))
+        )
+      } 
+    })
+    
+    TD <- bind_rows(TD, T2)
+  }
+  return(TD)
+}
+
+
+read_freq <- function(.version = 6, freq, .type = "odl") {
+  
+  # Weźmy konkretną częstotliwość.
+  TF <- TF %>% filter(version == .version)
+  TF <- TF %>% filter(fc == freq)
+  # TF <- TF %>% filter(NK == nk)
+  V_th <- 3
+  
+  TD <- tibble()
+  for(i in seq_len(nrow(TF))) {
+    obj <- TF[i, ]
+    filename <- obj$plik
+    V <- read_rds(filename)
+    T2 <- map_dfr(V, function(syg) {
+      syg <- unlist(syg)
+      rley <- rle(abs(syg) >= V_th)
+      les <- rley$lengths
+      les <- les[-c(1, length(les))]
+      vals <- rley$values
+      vals <- vals[-c(1, length(vals))]
+      
+      if( .type == "zak" ) {
+        return(
+          with(obj, 
+               tibble(
+                 NK = NK,
+                 pc = pc, fc = fc,
+                 fd = fd, dt = dt,
+                 A = A, f = f, lambda = lambda, 
+                 type = "zak", value = les[vals], N = N
+               ))
+        )
+      } else if( .type == "odl" ) {
+        return(
+          with(obj, 
+               tibble(
+                 NK = NK,
+                 pc = pc, fc = fc,
+                 fd = fd, dt = dt,
+                 A = A, f = f, lambda = lambda, 
+                 type = "odl", value = les[!vals], N = N 
+               ))
+        )
+      } else if( .type == "both" ) {
+        return(
+          with(obj, bind_rows(
+            tibble(
+              NK = NK,
+              pc = pc, fc = fc,
+              fd = fd, dt = dt,
+              A = A, f = f, lambda = lambda, 
+              type = "zak", value = les[vals], N = N
+            ),
+            tibble(
+              NK = NK,
+              pc = pc, fc = fc,
+              fd = fd, dt = dt,
+              A = A, f = f, lambda = lambda, 
+              type = "odl", value = les[!vals], N = N 
+            )
+          ))
+        )
+      } 
+    })
+    
+    TD <- bind_rows(TD, T2)
+  }
+  return(TD)
+  
+}