Estatística Aplicada à Ciência do Solo

github.com/walmes/EACS

Análise Exploratória

#-----------------------------------------------------------------------
# Carrega os pacotes necessários.

library(lattice)
library(latticeExtra)
library(nlme)
# library(doBy)
# library(multcomp)
library(plyr)
library(wzRfun)
library(EACS)

#-----------------------------------------------------------------------
# Análise exploratório dos dados.

# Pra facilitar o manuseio, vamos usar um nome curto.
cra <- teca_cra
str(cra)

cra$tens[cra$tens == 0] <- 0.1

xyplot(umid ~ tens | factor(loc), data = cra,
       groups = cam, type = c("o"), as.table = TRUE,
       strip = TRUE, layout = c(NA, 5),
       scales = list(x = list(log = 10)),
       xscale.components = xscale.components.log10ticks,
       auto.key = list(title = "Camada (cm)", cex.title = 1.1),
       ylab = expression("Umidade do solo" ~ (m^{3}~m^{-3})),
       xlab = expression(log[10] ~ "Tensão" ~ (kPa)))

#-----------------------------------------------------------------------
# Remove observações atípicas.

del <- with(cra, {
    (loc == 4 & cam == levels(cam)[3]) |
        (loc == 27 & cam == levels(cam)[1]) |
        (loc == 37 & cam == levels(cam)[2]) |
        (loc == 47 & cam == levels(cam)[2]) |
        (loc == 47 & cam == levels(cam)[3])
})

cra <- droplevels(cra[!del, ])

Ajuste da Curva de Retenção de Água do Solo

#-----------------------------------------------------------------------
# Ajuste da CRA.

xyplot(umid ~ tens,
       # data = subset(cra, loc == 40 & cam == "[40, 80)"),
       data = cra,
       scales = list(x = list(log = 10)),
       xscale.components = xscale.components.log10ticks,
       ylab = expression("Umidade do solo" ~ (m^{3} ~ m^{-3})),
       xlab = expression(log[10] ~ "Tensão" ~ (kPa)))

# Logaritmo na base 10 da tensão matricial.
cra$ltens <- log10(cra$tens)

# Expressão do modelo van Genuchten.
model <- umid ~ Ur + (Us - Ur)/(1 + exp(n * (alp + ltens)))^(1 - 1/n)

# Valores iniciais para os parâmetros da curva.
start <- list(Ur = 0.3, Us = 0.6, alp = -0.5, n = 4)

n00 <- nls(model, data = cra, start = start)
coef(n00)
##         Ur         Us        alp          n 
##  0.2390291  0.6519457 -0.4708593  2.4380958
#-----------------------------------------------------------------------
# Ajustar para cada unidade experimental, 50 loc x 3 cam = 150 ue, se
# não tivesse sido removido algumas curvas.

cra$ue <- with(cra, interaction(loc, cam, drop = TRUE))
nlevels(cra$ue)
## [1] 145
db <- groupedData(umid ~ ltens | ue,
                  data = cra, order.groups = FALSE)

n0 <- nlsList(model = model, data = db,
              start = as.list(coef(n00)))
c0 <- coef(n0)

pairs(c0)

# Alguma curva sem ajustar?
sum(!complete.cases(c0))
## [1] 1
plot(augPred(n0),
     strip = FALSE,
     as.table = TRUE,
     ylab = expression("Umidade do solo" ~ (m^{3} ~ m^{-3})),
     xlab = expression(log[10] ~ "Tensão" ~ (kPa)))

#-----------------------------------------------------------------------
# Determinar os demais parâmetros da curva de água do solo.

params <- as.data.frame(
    do.call(rbind, strsplit(rownames(c0),
                            split = "\\.")))

names(params) <- c("loc", "cam")
params <- transform(params,
                    loc = as.integer(loc),
                    cam = factor(cam, levels = levels(cra$cam)))
params <- na.omit(cbind(params, c0))

params <- within(params, {
    m <- 1 - 1/n
    d <- Us - Ur
    S <- -d * n * (1 + 1/m)^(-m - 1)
    I <- -alp - log(m)/n
    Ui <- Ur + (Us - Ur)/(1 + exp(n * (alp + I)))^(1 - 1/n)
    cad <- Ui - Ur
    rm(d, m)
})

str(params)
## 'data.frame':    144 obs. of  10 variables:
##  $ loc: int  1 12 23 34 45 47 48 49 50 2 ...
##  $ cam: Factor w/ 3 levels "[0, 5)","[5, 40)",..: 1 1 1 1 1 1 1 1 1 1 ...
##  $ Ur : num  0.223 0.169 0.214 0.184 0.251 ...
##  $ Us : num  0.648 0.622 0.667 0.66 0.576 ...
##  $ alp: num  -0.724 -0.578 -0.608 -0.72 -0.809 ...
##  $ n  : num  3.59 4.24 3.09 4.87 2.38 ...
##  $ cad: num  0.227 0.239 0.245 0.249 0.182 ...
##  $ Ui : num  0.45 0.408 0.459 0.433 0.433 ...
##  $ I  : num  0.815 0.642 0.734 0.767 1.037 ...
##  $ S  : num  -0.341 -0.439 -0.306 -0.537 -0.159 ...
##  - attr(*, "na.action")=Class 'omit'  Named int 88
##   .. ..- attr(*, "names")= chr "40.[5, 40)"
# addmargins(xtabs(~loc + cam, data = params))
params <- arrange(params, loc, cam)

splom(params[, -(1:2)], type = c("p", "r"))

Pareando Dados de Produção e da CRA

# Valores das variáveis de produção (se repetem nas tensões e camadas).
plan <- unique(subset(cra, cam == levels(cam)[1] & tens == max(tens),
                      select = c(loc, alt, dap, vol, prod)))
str(plan)
## 'data.frame':    49 obs. of  5 variables:
##  $ loc : int  1 2 3 4 5 6 7 8 9 10 ...
##  $ alt : num  12.9 11.9 22.5 20.4 15.6 ...
##  $ dap : num  0.194 0.182 0.348 0.304 0.227 ...
##  $ vol : num  0.2707 0.0963 0.4974 0.4074 0.2165 ...
##  $ prod: num  68.2 24.3 125.3 102.7 54.6 ...
#-----------------------------------------------------------------------
# Junta os valores de produção com parâmetros da CRA. Valores de
# produção vão se repetir para as camadas.

crap <- merge(plan, params)
str(crap)
## 'data.frame':    141 obs. of  14 variables:
##  $ loc : int  1 1 1 2 2 2 3 3 3 4 ...
##  $ alt : num  12.9 12.9 12.9 11.9 11.9 ...
##  $ dap : num  0.194 0.194 0.194 0.182 0.182 ...
##  $ vol : num  0.2707 0.2707 0.2707 0.0963 0.0963 ...
##  $ prod: num  68.2 68.2 68.2 24.3 24.3 ...
##  $ cam : Factor w/ 3 levels "[0, 5)","[5, 40)",..: 2 3 1 1 2 3 1 2 3 2 ...
##  $ Ur  : num  0.178 0.188 0.223 0.131 0.165 ...
##  $ Us  : num  0.58 0.647 0.648 0.697 0.573 ...
##  $ alp : num  -0.833 -0.722 -0.724 -0.548 -0.547 ...
##  $ n   : num  3.11 3.25 3.59 4.01 2.92 ...
##  $ cad : num  0.217 0.247 0.227 0.3 0.222 ...
##  $ Ui  : num  0.396 0.435 0.45 0.431 0.387 ...
##  $ I   : num  0.957 0.835 0.815 0.62 0.691 ...
##  $ S   : num  -0.273 -0.329 -0.341 -0.515 -0.257 ...

Informações da sessão

## Atualizado em 28 de julho de 2016.
## 
## R version 3.3.1 (2016-06-21)
## Platform: x86_64-pc-linux-gnu (64-bit)
## Running under: Ubuntu 16.04 LTS
## 
## locale:
##  [1] LC_CTYPE=pt_BR.UTF-8       LC_NUMERIC=C              
##  [3] LC_TIME=pt_BR.UTF-8        LC_COLLATE=en_US.UTF-8    
##  [5] LC_MONETARY=pt_BR.UTF-8    LC_MESSAGES=en_US.UTF-8   
##  [7] LC_PAPER=pt_BR.UTF-8       LC_NAME=C                 
##  [9] LC_ADDRESS=C               LC_TELEPHONE=C            
## [11] LC_MEASUREMENT=pt_BR.UTF-8 LC_IDENTIFICATION=C       
## 
## attached base packages:
## [1] stats     graphics  grDevices utils     datasets  base     
## 
## other attached packages:
##  [1] plyr_1.8.4          nlme_3.1-128        latticeExtra_0.6-28
##  [4] RColorBrewer_1.1-2  lattice_0.20-33     knitr_1.13         
##  [7] EACS_0.0-1          wzRfun_0.65         roxygen2_5.0.1     
## [10] devtools_1.12.0    
## 
## loaded via a namespace (and not attached):
##  [1] Rcpp_0.12.5      formatR_1.4      git2r_0.15.0    
##  [4] methods_3.3.1    tools_3.3.1      digest_0.6.9    
##  [7] evaluate_0.9     memoise_1.0.0    Matrix_1.2-6    
## [10] yaml_2.1.13      curl_0.9.7       rpanel_1.1-3    
## [13] mvtnorm_1.0-5    withr_1.0.2      httr_1.2.1      
## [16] stringr_1.0.0    grid_3.3.1       R6_2.1.2        
## [19] survival_2.39-5  rmarkdown_1.0    multcomp_1.4-6  
## [22] TH.data_1.0-7    magrittr_1.5     codetools_0.2-14
## [25] htmltools_0.3.5  MASS_7.3-45      splines_3.3.1   
## [28] sandwich_2.3-4   stringi_1.1.1    doBy_4.5-15     
## [31] zoo_1.7-13