library(tidyverse)

# Proč by bylo zbytečné přidávat jako vstupní parametr na.rm,
# když je finite = TRUE? Co kdyby vektor x obsahoval chybějící hodnotu(y)? 
# Mělo by nastavení na.rm = FALSE a na.rm = TRUE nějaký dopad na výstup funkce.
rescale_01 <- function(x, na.rm = FALSE) {
  rng <- range(x, na.rm = na.rm, finite = TRUE)
  out <- (x - rng[1]) / (rng[2] - rng[1])
  out[out == -Inf] <- 0
  out[out == Inf] <- 1
  return(out)
}

x <- c(NA, 5, 9, 6, 1, -Inf, Inf)
rescale_01(x)
rescale_01(x, na.rm = TRUE)
# Hodnoty NA jsou společně s -Inf a Inf považovány za finite, takže
# se s nimi tak jako tak nebude počítat, když ve funkci rescale_01()
# Bude napevno nastaveno finite = TRUE

# Zkuste funkci rescale_01() upravit tak, aby se hodnoty -Inf 
# transformovaly na nuly a hodnoty -Inf na jedničky.
rescale_01 <- function(x) {
  rng <- range(x, finite = TRUE)
  (x - rng[1]) / (rng[2] - rng[1])
}

x <- c(NA, -Inf, 5, 9, 6, 1, Inf)
rescale_01(x)

rescale_01 <- function(x) {
  rng <- range(x, finite = TRUE)
  (x - rng[1]) / (rng[2] - rng[1])
  x[x == -Inf] <- 0
  x[x == Inf] <- 1
  x
}

rescale_01(x)

# Zkuste přijít na to, co dělá následující kód, 
# a pak vytvořit vlastní funkci, která budě dělat totéž, a dát ji výstižný název.

# Kód 1
x <- c(1:7, NA, NA,NA)
x
mean(is.na(x))

# Kód počítá podíl chybějících hodnot, proto bychom funkci mohli 
# pojmenovat prop_na()
prop_na <- function(x) {
  mean(is.na(x))
}

prop_na(x)

# Kód 2
x <- 1:10
x / sum(x, na.rm = TRUE)

# Kód tranformuje x tak, že součet hodnot bude roven 1
# proto bychom funkci mohli pojmenovat sum_to_one()

sum_to_one <- function(x) {
  x / sum(x, na.rm = TRUE)
}
sum_to_one(x) 
sum_to_one(x) %>% sum()

# Najděte si rovnici pro výpočet rozptylu a zkuste napsat vlastní funkci 
# variance() pro výpočet rozptylu. Můžete přitom využít stávající funkce 
# jako mean() a length().
variance <- function(x, na.rm = FALSE) {
  if (any(is.na(x)) && na.rm == FALSE) {
    NA_real_ # V případě chybějícíh hodnot a na.rm = FALSE vrátit NA
  } else { # Jinak vyřadit chybějící hodnoty
    x <- x[!is.na(x)] # vyřadit z x chybějící hodnoty
    n <- length(x) # počet prvků
    m <- mean(x) # průměr
    sum_sq <- sum((x-m)^2) # součet čtverců odchylek od průměru
    sum_sq / (n - 1) # konečný výpočet rozptylu
  }
}

x <- c(rnorm(30), NA, NA)
x

variance(x)
variance(x, na.rm = TRUE)
var(x, na.rm = TRUE)

# Zkuste přijít na to, co tyto funkce dělají, a podle toho jim dá vhodnější název.
# Funkce 1

# Kontroluje, jestli prvky začínají daným prefixem
had_prefix <- function(string, prefix) {
  substr(string, 1, nchar(prefix)) == prefix
}

had_prefix(c("abc", "abcde", "ad", "ba"), "ad")


# Funkce 2
# Zahodí poslední prvek
drop_last <- function(x) {
  if (length(x) <= 1) return(NULL)
  x[-length(x)]
}

f2(1:7)
f2(1:6)
f2(c("a", "b", "c"))

# Funkce 3
# Recykluje y, dokud nemá délku jako x
recycle <- function(x, y) {
  rep(y, length.out = length(x))
}

1:3
1:10

recycle(1:5, 1:3)


# Vytvořte funkci greeting() bez vstupních argumentů, 
# jejímž výstupem bude "Dobré ráno!" od 5:00 do 11:59, 
# "Dobré odpoledne!" od 12:00 do 16:59 nebo "Dobrý večer!" v ostatních 
# případech. Ke zjištění aktuální denní hodiny můžete použít.

as.integer(format(Sys.time(), format = "%H"))

greeting <- function() {
  hour <- as.integer(format(Sys.time(), format = "%H"))
  if (between(hour, 5, 11)) {
    "Dobré ráno!"
  } else if (between(hour, 12, 16)) {
    "Dobré odpoledne!"
  } else {
    "Dobrý večer!"
  }
}
greeting()

# Proč toto nefunguje?
commas <- function(...) {
  paste0(..., collapse = ", ")
}

commas(letters)
commas(letters, collapse = "-")
# Protože bychom tak collapse použili dvakrát, jednou je vložený pomocí ...
# ale zároveň je napevno nastavený na ", "

# a je nutné funkci upravit takto (kdybychom chtěli upravovat argument collapse)?
commas <- function(..., collapse = ", ") {
  paste0(..., collapse = collapse)
}

commas(letters)
commas(letters, collapse = "-")

# Zjistěte, k čemu ve funkci mean() slouží argument trim.
# K ořezání průměru z obou stran (odsranění 0–50% hodnot z obou stran)


# Defaultní hodnota argumentu method pro výpočet korelací funkcí cor() 
# je method = c("pearson", "kendall", "spearman") Co to znamená? 
# Je defaultní "pearson", "kendall" nebo spearman"?

# Zkuste si to na této funkci. Všimněte si, že využívá jinou funkci, 
# match.arg(). Co match.arg() hlidá?
basic_math <- function(x, y, operator = c("plus", "minus", "times", "divide")) {
  op <- match.arg(operator)
  switch (op,
          plus = x + y,
          minus = x - y,
          times = x * y,
          divide = x / y
  )
}

basic_math(3, 6)
basic_math(3, 6, "power")
basic_math(3, 6, "m") # Je to divné, ale stačí "parciální" match.

# Defaultně se použije první hodnota, pokud nestanovíme jinak
# Ve funkci cor() je to "person", ve funkci basic_math() je to "plus"


# Zkuste vytvořit funkci not.na(), která bude opakem is.na()
not.na <- function(x) {
  !is.na(x)
}

# zkuste vytvořit funkci sum_na(), která vypočte součet chybějících hodnot
sum_na <- function(x) {
  sum(is.na(x))
}

# Zkuste vytvořit funkci mean_if(), která vypočte průměr atomického vektoru 
# pokud počet chybějících hodnot nepřesáhne určitou hodnotu
mean_if <- function(x, max.na = 0) {
  n_missing <- sum_na(x)
  
  if (n_missing > max.na) {
    NA_real_
  } else {
    mean(x, na.rm = TRUE)
  }
}

# Zkuste vytvořit funkci reg_linear, která pouze trochu předělá funkci 
# lm() tak, ať prvním argumentem je použitý dataset, nikoli regresní rovnice.
reg_linear <- function(data, formula) {
  lm(formula = formula, data = data)
}

# Zkuste vytvořit funkci item_range pro tvorbu vektoru s názvem položek, 
# která bude mít tři argumenty: prefix (“předpona”) a range (číselný rozsah) 
# a volitelný argument width pro konstantní počet cifer. 
# Například item_range("rses", range = 1:3, width = 2) by 
# mělo vytvořit vektor c("rses01", "rses02", "rses03"). 
# Zkuste při tom uplatnit funkce str_c() a str_pad(), 
# jejichž fungování si můžeme ukázat:
item_range <- function(prefix, range, width = NULL) {
  
  if (!is.null(width)) {
    range <- str_pad(range, width = width, pad = "0")
  }
  
  str_c(prefix, range)
}

item_range("rses", 1:10)
item_range("rses", 1:10, width = 2)
item_range("rses", c(1, 3, 5, 6, 9), width = 3)


# Cvičení Zkuste předchozí funkci rozšířit tak, ať kromě průměru a SD 
# počítá také jiné deskriptivní statistiky, např. medián a mezikvartilové 
# rozpětí a počet validních hodnot. Můžete uplatnit funkce median(), 
# IQR() a také !is.na() a sum(). Zmeňte také funkci tak, ať je 
# na.rm měnitelný vstupní argument (tj. ať není v každé statistické 
# funkci napevno na.rm = TRUE).
my_summarise <- function(data, group_var, summarise_var) {
  data %>%
    group_by(across({{ group_var }})) %>% 
    summarise(
      across({{ summarise_var }},
             list(M = ~mean(., na.rm = TRUE),
                  SD = ~sd(., na.rm = TRUE)),
             .names = "{.fn}_{.col}")
    )
}

my_summarise <- function(data, group_var, summarise_var, na.rm = TRUE) {
  data %>%
    group_by(across({{ group_var }})) %>% 
    summarise(
      across({{ summarise_var }},
             list(M = ~mean(., na.rm = na.rm),
                  SD = ~sd(., na.rm = na.rm),
                  Mdn = ~median(., na.rm = na.rm),
                  IQR = ~IQR(., na.rm = na.rm),
                  n_val = ~sum(!is.na(.))),
             .names = "{.fn}_{.col}")
    )
}

my_summarise(starwars, 
             group_var = species, 
             summarise_var = height)

# Zkuste funkci plot_scatter() rozšířit o další argumenty, např. 
# barvu či velikost bodů. Zkuste vytvořit jednoduché grafické funkce 
# podobné plot_scatter(), ale pro jiné typy grafů, např. boxplot nebo histogram.
df <- datasets::airquality %>% 
  set_names(c("ozone", "solar_rad", "wind", "temp", "month", "day")) %>% 
  as_tibble()
df

plot_scatter <- function(data, x, y, 
                         color = "black",
                         size = 1) {
  data %>% 
    ggplot(aes( .data[[x]], .data[[y]] )) +
    geom_point(color = color, size = size)
}

plot_scatter(df, x = "temp", y = "solar_rad",
             color = "blue", size = 3)



# Zkuste vytvořit funkci row_na(), která vypočte součet chybějících 
# hodnot na jednotlivém řádku pro zvolené sloupce. 
# Můžete vlastně jen vhodným způsobem upravit funkci row_sum(). 
# Jedniným argumentem budou vybrané sloupce.

row_sum <- function(cols) {
  cur_data() %>% 
    select( {{cols}}) %>% 
    rowSums()
}


row_na <- function(cols) {
  cur_data() %>% 
    select( {{cols}}) %>% 
    is.na() %>% 
    rowSums()
}

# Zkuste vytvořit funkci row_mean(), která místo sumy vypočte průměr 
# z určených sloupců pro každý řádek. Můžeme k tomu využít opět funkce 
# cur_data() a select(), ale namísto rowSums() použijte rowMeans(). 
# Jediným argumentem budou vybrané sloupce.
row_mean <- function(cols) {
  cur_data() %>% 
    select( {{cols}}) %>% 
    rowMeans()
}

# Zkuste do funkce row_mean() přidat další argument max.na s defaultní 
# hodnotou 0 a funkci upravit tak, aby se průměr vypočetl pro daný řádek 
# jen tehdy, pokud je počet chybějících hodnot ve vybraných sloupcích 
# menší nebo rovno právě hodnotě argumentu max.na (jinak by funkce měla vrátit NA).
row_mean <- function(cols, max.na = 0) {
  data <- cur_data() %>% 
    select( {{cols}})
  
  na <- data %>% 
    is.na() %>% 
    rowSums()
  
  m <- data %>% 
    rowMeans(na.rm = TRUE)
  
  m[na > max.na] <- NA_real_
  
  return(m)
}

df %>% 
  mutate(
    ozone_sr = row_mean(c(ozone, solar_rad))
  )

# Jako poslední úpravu se pokuste funkci row_mean() rozšířit tak, 
# aby kontrolovala, že všechny vybrané slupce jsou numerickými vektory, 
# a pokud toho není dodržena, aby vrátila chybovou hlášku, např. 
# “All selected columns must be numeric.”
row_mean <- function(cols, max.na = 0) {
  data <- cur_data() %>% 
    select( {{cols}})
  
  all_numeric <- data %>% 
    map_lgl(is.numeric) %>% 
    all()
  
  stopifnot("All selected columns must be numeric." = all_numeric)
  
  na <- data %>% 
    is.na() %>% 
    rowSums()
  
  m <- data %>% 
    rowMeans(na.rm = TRUE)
  
  m[na > max.na] <- NA_real_
  
  return(m)
}