SEMANA 10 - Programação Funcional - Split-Apply-Combine - Atividade B10

Gustavo Eduardo Marcatti

Resolução dos exercícios de aulas anteriores com paradigma funcional

Aula SEMANA 05 - Operações de Repetição: loop visão geral

Imprimir Bom dia na tela
#----------------- imperativo -----------------------------------#
N <- 5 # quantidade de vezes
for(i in 1:N) {
   cat("Boa tarde R!", i, "\n")
}

#----------------- funcional ------------------------------------#
fun_bom_dia <- function(vezes) {
   frase <- paste("Boa tarde R!", vezes, "\n")
   return(frase)
}
# fun_bom_dia <- function(vezes) return(paste("Boa tarde R!", vezes, "\n"))

N <- 5
cat(sapply(1:N, fun_bom_dia), sep = "")

Aula SEMANA 07 - Operações de Repetição: modificar vetor em loop

Algoritmo de soma em um vetor
#----------------- imperativo -----------------------------------#
vetor <- c(1, 2, 34, 12, 2)
N <- length(vetor)
soma <- 0
for (i in 1:N) {
   soma <- soma + vetor[i]
}
soma

#----------------- funcional ------------------------------------#
vetor <- c(1, 2, 34, 12, 2)
sum(vetor)
Obter o quadrado de elementos de um vetor
#------------ Apenas imprimir na tela ---------------------------#
#----------------- imperativo -----------------------------------#
vetor <- c(1, 2, 34, 12, 2)
for (i in 1:length(vetor)) {
   print(vetor[i]^2)
}

#----------------- funcional ------------------------------------#
vetor <- c(1, 2, 34, 12, 2)
vetor^2

#------------ Armazenar o resultado em um vetor -----------------#
#----------------- imperativo -----------------------------------#
vetor <- c(1, 2, 34, 12, 2)
vet_quad <- vector("numeric", length(vetor))
for (i in 1:length(vetor)) {
   quad <- vetor[i]^2
   vet_quad[i] <- quad
}

#----------------- funcional ------------------------------------#
vetor <- c(1, 2, 34, 12, 2)
vet_quad <- vetor^2
Elementos divisíveis por 4
#----------------- imperativo -----------------------------------#
vetor <- c(20, 2, 34, 12, 2)
div4_log <- vector("logical", length(vetor))
for (i in 1:length(vetor)) {
   if (vetor[i] %% 4 == 0) {
      div4_log[i] <- TRUE # verdadeiro
   }
}
div4_log
div4 <- vetor[div4_log]

#----------------- funcional ------------------------------------#
vetor <- c(20, 2, 34, 12, 2)
div4_log <- ifelse(vetor %% 4 == 0, TRUE, FALSE)
div4 <- vetor[div4_log]

Aula SEMANA 08 - Estruturas de dados. Indexação. Loop em data.frame (tibble) - P1

Ajuste de modelos
#----------------- imperativo -----------------------------------#
# importar dados
# ler arquivo hospedado na internet
library(httr)
url <- "https://gmarcatti.github.io/dados/dados.xlsx"
GET(url, write_disk(arq <- tempfile(fileext = ".xlsx")))
# install.packages("readxl")
library(readxl)
dados <- read_excel(arq)
# dados <- read_excel("C:/dados/dados.xlsx") # se o arquivo estiver no pc

# identificar quantidade de ajustes (repetições)
uni_gen <- unique(dados$genotipo)
N <- length(uni_gen)
# estrutura tibble para receber parametros do modelo
require(tibble)
coefs <- tibble(genotipo = vector("character", N),
                b0 = vector("numeric", N),
                b1 = vector("numeric", N))
# como acessar os elementos de interesse

# Processo de repetição (loop for)
for (i in 1:N) {
   dados_i <- subset(dados, genotipo == uni_gen[i])
   lm_i <- lm(volume ~ idade, dados_i)
   coefs[i, "genotipo"] <- uni_gen[i]
   coefs[i, "b0"] <- lm_i$coefficients[[1]]
   coefs[i, "b1"] <- lm_i$coefficients[[2]]
}

#----------------- funcional ------------------------------------#
# importar dados
# ler arquivo hospedado na internet
library(httr)
url <- "https://gmarcatti.github.io/dados/dados.xlsx"
GET(url, write_disk(arq <- tempfile(fileext = ".xlsx")))
# install.packages("readxl")
library(readxl)
dados <- read_excel(arq)
# dados <- read_excel("C:/dados/dados.xlsx") # se o arquivo estiver no pc

ajuste_lm <- function(d) { # função a ser aplicada
   lm_func <- lm(volume ~ idade, d)
   dados_func <- tibble(genotipo = d$genotipo[1],
                        b0 = lm_func$coefficients[[1]],
                        b1 = lm_func$coefficients[[2]])
   return(dados_func)
}
# ajuste_lm(dados) # testar a função

# Estratégia de split-apply-combine
d_split <- split(dados, dados$genotipo) # split
aplicar_func <- lapply(d_split, ajuste_lm) # apply
coefs <- Reduce(rbind, aplicar_func) # combine

Aula SEMANA 09 - Estruturas de dados. Indexação. Loop em data.frame (tibble) - P2

Ajuste de modelo não linear e plotar ajuste
#----------------- imperativo -----------------------------------#
# importar dados
# ler arquivo hospedado na internet
library(httr)
url <- "https://gmarcatti.github.io/dados/dados.xlsx"
GET(url, write_disk(arq <- tempfile(fileext = ".xlsx")))
# install.packages("readxl")
library(readxl)
dados <- read_excel(arq)
# dados <- read_excel("C:/dados/dados.xlsx") # se o arquivo estiver no pc

library(minpack.lm)
library(tibble)
prod <- c("G20", "G22", "G4", "G3", "G2", "G24", "G7", "G18")
inter <- c("G5", "G12", "G9", "G21", "G14", "G11", "G8", "G6")
resis <- c("G1", "G16", "G23", "G15", "G13", "G10", "G19", "G17")
dados$info_gen <- ""
dados[dados$genotipo %in% prod, "info_gen"] <- "produtivos"
dados[dados$genotipo %in% inter, "info_gen"] <- "intermediários"
dados[dados$genotipo %in% resis, "info_gen"] <- "resistentes"
# 1. Identificar e quantificar as classes de interesse
uni_gen <- unique(dados$info_gen)
N <- length(uni_gen)
# 2. Como executar o procedimento e como acessar os resultados
# 3. Criar uma data.frame (ou tibble) para receber os resultados
coefs <- tibble(info_gen = character(N),
                b0 = numeric(N),
                b1 = numeric(N))
plot(dados$idade, dados$volume, xlab = "Idade (anos)",
     ylab = "Volume (m³/ha)")
cores <- c("orange", "green", "red")
# 4. Executar o processo de repetição (loop)
for (i in 1:N) {
   # 4.1. Filtrar a classe de interesse
   d_i <- subset(dados, info_gen == uni_gen[i])
   # 4.2. Executar os comandos necessários
   nls_i <- nlsLM(volume ~ exp(b0 - b1/idade), d_i,
                  start = list(b0 = 1, b1 = 1))
   points(d_i$idade, fitted(nls_i), col = cores[i])
   # 4.3. Acessar os resultados
   resumo_i <- summary(nls_i)
   b0coef = resumo_i$coefficients[, "Estimate"][[1]]
   b1coef = resumo_i$coefficients[, "Estimate"][[2]]
   # 4.4. Modificar a data.frame criada em (3) para receber os resultados
   coefs[i, "info_gen"] <- uni_gen[i]
   coefs[i, "b0"] <- b0coef
   coefs[i, "b1"] <- b1coef
}
legend("topleft", legend = uni_gen, col = cores, pch = 1)

#----------------- funcional ------------------------------------#
library(minpack.lm)
library(readxl)
library(tibble)
library(ggplot2) # install.packages(ggplot2)
# importar dados
# ler arquivo hospedado na internet
library(httr)
url <- "https://gmarcatti.github.io/dados/dados.xlsx"
GET(url, write_disk(arq <- tempfile(fileext = ".xlsx")))
# install.packages("readxl")
library(readxl)
dados <- read_excel(arq)
# dados <- read_excel("C:/dados/dados.xlsx") # se o arquivo estiver no pc

prod <- c("G20", "G22", "G4", "G3", "G2", "G24", "G7", "G18")
inter <- c("G5", "G12", "G9", "G21", "G14", "G11", "G8", "G6")
resis <- c("G1", "G16", "G23", "G15", "G13", "G10", "G19", "G17")
dados$info_gen <- ""
dados[dados$genotipo %in% prod, "info_gen"] <- "produtivos"
dados[dados$genotipo %in% inter, "info_gen"] <- "intermediários"
dados[dados$genotipo %in% resis, "info_gen"] <- "resistentes"

func_aplicar <- function(d) {
   nls_func <- nlsLM(volume ~ exp(b0 - b1/idade), d,
                     start = list(b0 = 1, b1 = 1))
   dados_func <- tibble(info_gen = d$info_gen[1],
                        idade = d$idade,
                        volume = fitted(nls_func))
   return(dados_func)
}

#func_aplicar(dados)
d_split <- split(dados, dados$info_gen) # split
d_apply <- lapply(d_split, func_aplicar) # apply
volume_est <- Reduce(rbind, d_apply) # combine

p <- ggplot(dados, aes(idade, volume)) +
   geom_point(alpha = 0.25) +
   labs(x = "Idade (anos)", y = "Volume (m³/ha)") +
   geom_line(data = volume_est, aes(colour = info_gen), size = 1.5)
p

p <- ggplot(dados, aes(idade, volume)) +
   geom_point(alpha = 0.25) +
   labs(x = "Idade (anos)", y = "Volume (m³/ha)") +
   geom_line(data = volume_est, aes(colour = info_gen), size = 1.5) +
   facet_grid(~info_gen)
p