#---------------------------------------------------------------#
## programación funcional, aspectos genéricos útiles            ##

rm(list =ls()) # esta instrucción vacía el entorno


#---------------------------------------------------------------#
#   Reproducción código wikipedia sobre closure
#// Return a function that approximates the derivative of f
#// using an interval of dx, which should be appropriately small.
#
#   function derivative(f, dx) {
#      return function (x) {
#        return (f(x + dx) - f(x)) / dx;
#        };
#      }

                             # ejemplo útil, derivada de una
                             # función en un punti
derivada  <- function (f, dx) {
              dummy <- function(x){
                      (f(x + dx) - f(x))/dx
                      }
              }

  
d_sin <- derivada(sin,1.0e-10)   # devivada de la función seno
d_sin(pi)                       # -1
d_sin(pi/4)                     # ok 0.707
sqrt(2)/2                       # valor previsto 0.707

#---------------------------------------------------------------#

library(lambda.tools) # las herramientas necesarias

d <- cars # ejemplos de datos incluidos en R
anylength(cars) # longitud generalizada

anynames(d) # nombres generalizados
tipos_d <- anytypes(d) # tipos generalizados
tipos_d["speed"] # el tipo que coincide con un nombre

# divisiones generalizadas
chomp(d, head = 40, tail = 8) # eliminar filas


m <- as.matrix(d) # transformación a matriz
head()
tail (m)

max(m[,2]) # max y min columna 2
min(m[,2])
m[,2] <- confine(m[,2],10,100)# devuelve entre 10 y 100 inclusive
head(m)
tail(m)

#---------------------------------------------------------------#
                              # digitalización manua
m[,2] <- quantize(m[,2], bins=c(10,20,30,40,50,60,70,80,90,100))
head(m)
tail(m)

                              # digitalización automática
n = 10                        # en 10 valores
e <-max(m[,2]) - min(m[,2])
e <-round((e+n)/10)
s <- 1:n                      # secuencia de enteros
s <- s * e                    # escalado
m[,2] <- quantize(m[,2], bins=c(s))


f <- function(x){x/log(x+1)}      # una función
m[,2] <- map(m[,2],f)             # transformación
anynames(m)[2] <- "dist_tranform" # adapatar el nombre de col
head(m)
tail(m)

#---------------------------------------------------------------#
                                  # composición de funciones
f <- function(x){2*x}             # doble
g <- function(x){x^2}             # cuadrado
h <- sin                          # sinus función básica

                                  # función de composición
c_    <- function(f, g){function(...) f(g(...))}

fOg <- c_(f,g)                    # componemos g y g
fOg(1)                            # Ã§a se obtiene 2
f(g(1))                           # confimación simple
g(f(1))                           # gOf diferente fOg

fOgOh <- c_(fOg,h)                # para componer 3 funciones
m[,2] <- map(m[,2],fOgOh)         #  
head(m)
tail(m)

#---------------------------------------------------------------#
                                  # objeto con un danger
beurk <- c(NA,1,NaN,Inf)
ok    <- c(0,1,-5,Inf)
is.bad(beurk)
is.bad(ok)                        # Inf no es un bad!

                                  # contar las pb
sum(is.bad(beurk))                # 2 Elementos bad
sum(is.bad(ok))                   # 0 Elementos bad

beurk_df <- data.frame(beurk,ok)  # ídem para un dataframe
sum(is.bad(beurk_df))             # 2 Elementos bad

is.empty(list())                  # TRUE, detección objeto vacío

                                  # check longitud = 1
is.scalar("e")                    # TRUE
is.scalar(1)                      # TRUE
is.scalar(c(1,1))                 # FALSE

                                  # accesos seguros
item(m[,2],1)                     # acceso normal
item(m[,2],100)                   # fuera de los márgenes
item(m[,2],0)                     # fuera de los márgenes


                                  # para memorizar
                                  # recordar el número
                                  # de llamadas
G_acc <- 0
G_fun <- function(){G_acc <<- G_acc +1}

G_acc <- 0
G_fun()                           # G_fun está silenciado

g <- G_fun()                      # pero devuelve un valor !

print(g)                          # devuelve 2 porque hay 2 pasadas
                                  
                                  # más sólido
G_fun <- function(){G_acc <<- get("G_acc") +1}


# comprobar si los valores son iguales
# detener de lo contrario
# en caso contrario detener el programa
s <- sin(pi) # del género 1.224606e-16 (infinitamente pequeño)
stopifnot(s == 0) # no es cero ¡PARA mal!
stopifnot(round(s*1.0e10) == 0) # ok, casi cero

# comprobar si dos valores son iguales
# en caso contrario detener el programa
c <-cos(pi/2)
stopifnot(s == c) # no es igual!
stopifnot(round(abs(s-c)*1.0e10) == 0 ) # ok casi igual

# closure (=closure)
library (functional) # para CurryL (Lazy Curry)
add_1 <- CurryL(sum, 1) # agregar 1
add_1(10) # 11
mul_2 <- CurryL(`*`,2) # multiplicar por 2
mul_2(10) # 20

add_1(1:3, NA) #NA
add_1 <- CurryL(sum, 1, na.rm = TRUE) # agregar 1 resistir NA
add_1 (1: 3, NA) # 7
mul_2(add_1(1:3,NA)) # 14: estas funciones simples
# componer fácilmente!

#  pequeña trampa
div_2 <- CurryL(`/`,2) # div por 2 ???
div_2(10) # Ups, ¡obtenemos 0.2!
# esta funcion permite dividir 2
# por otra cosa
div_2(0) # Inf ... efectivamente

require(pryr) # muchos trucos funcionales
# Y varios
# ATTENTION pryr crea una función llamada f
# que genera funciones anónimas

# otra forma de invocar una función
f_ <- function(x,y,z) {x+y/z} # una función de 3 variables

do_call(f_, lista(z = 100, x =2, y = 1)) # 2.01 llamada simple

do_call(f_, list(z = Inf, # 6.28 también funciona
                 x = 2*pi,
                 y = 1)
)
# ese era el objetivo
# funcional
# varias composiciones
do_call(f_, lista(z = div_2(100),
                        x = mul_2(5),
                        y = 1)
)

# introspección de código
args(derivada) # los argumentos de la función
body(derivada) # el cuerpo de la función, raro
# devuelve una función... es decir
# un closure
unenclose(derivada) # para ver lo que hay en el
# cierre
args(d_sin) # tomar una función como argumento
# es un closure
body(d_sin) # y sí, solo vemos la parte
# derivada
unenclose(d_sin) # para ver lo que hay en el
                                 # closure

#---------------------------------------------------------------#
                                 # introspection code packages
find_funs("package:base", fun_args, "FUN")
args(apply)
find_funs("package:base", fun_calls, "apply")
body(Map)

                                  # ¿o encontramos una función?
where("plot")                     # /R/R-3.4.3/library/graphics

un_objeto <-setRefClass("una_clase_RC")
otype(un_objeto)                   # RC   : objeto de clase RC
otype(add_1)                      # base : no un objeto en sentido OO
body(un_objeto)                    # se contenta con llamar a new ...

                                 
ls()                              # lista de todos los objetos, no en sentido OO
rls()                             # ídem per recursivo


#---------------------------------------------------------------#
ast((3*x+1)/2*div_2(y)) # si tiene alguna duda sobre esto
# las órdenes de ejecución de
# elementos de una expresión

# consumo de memoria de un código
h <- function(){x <- datasets::WWWusage}
mem_change(h()) # -7.23 kB: consumo de memoria
mem_used() # 103 MB usados por R


#---------------------------------------------------------------#
# funcional y defensivo                                     #
#---------------------------------------------------------------#
library(lambda.r)                 # estilo funcinal
a1(x) %as% {x+1}                  # acumulador 1
a1(1)                             # 2
m2(x) %:=% {2*x}                  # doble
m2(2)                             # 4
a1(m2(10))                        # 21 , composición


dxy(x,y) %as% {x/y}               # divide x por y
dxy(1,2)                          # 0.5
dxy(1,0)                          # Inf
dxy("a",1)                        # ERROR
dxy(0,0)                          # NaN

rm(dxy)                           # volvemos a empezar
dxy(0,0) %as% {0}                 # fuerza a 0
dxy(x,y) %as% {x/y}               # divide x por y

dxy(1,2)                          # 0.5
dxy(0,0)                          # 0 (en lugar de NaN)


rm(dxy)                           # volvemos a empezar
dxy(0,0) %as% {0}                 # fuerza a 0
dxy(x,y) %when% {                 # sentencias de protección
  is.numeric(x)
  is.numeric(y)
  y != 0
  !is.bad(c(x,y))
  } %as% {
    x/y
  }

dxy(1,2)                          # 0.5
dxy(0,0)                          # 0   
dxy(1,0)                          # ERROR
dxy("a",1)                        # ERROR

# completamos la función !!
dxy(x,y) %as% {NA} # pasar a esta definición
# si la cláusula de protección
# error anterior

dxy(1,2) # 0.5
dxy(0,0) # 0
dxy(1,0) # NA en lugar de ERROR
dxy("a",1) # NA en lugar de ERROR
dxy(1,NaN) # NA porque es "bad"
dxy(1,Inf) # 0 porque Inf es un valor posible
dxy(Inf,1) # Inf
dxy(c(10,20),2) # 5 y 10
dxy(c(10,20),c(2,10)) # 5 y 2
dxy(c(10,NA),2) # NA no de miembro a miembro!
dxy(2,c(2,10))                    # ERROR

dxy                               # introspection stucture clauses
describe(dxy,1)                   # body parte 1
describe(dxy,2)                   # body parte 2
describe(dxy,3)                   # body parte 3
seal(dxy)                         # ahora dxy ya no es modificable


polymorphe(x,FALSE) %as% {x/10}   # función diferente según param 2
polymorphe(x,TRUE)  %as% {x/100}
polymorphe(100,FALSE)             # 10
polymorphe(100,TRUE)              # 1

rm(polymorphe)                    # otra función polimorfa
polymorphe(x, 1) %as% {x + 1}
polymorphe(x, 2) %as% {x *2}
polymorphe(x)    %as% {x^2}

polymorphe(10,1)                  # 11
polymorphe(10,2)                  # 20
polymorphe(10, "toto")            # ERROR
polymorphe(10, 0)                 # ERROR
polymorphe(7)                     # 49



                                  # crear su propio operador
x %//% y  %as% dxy(x,y)
1 %//% 2                          # 0.5
1 %//% 0                          # NA
c(10,20) %//% c(10,100)           # 1.0    0.2  
1 %//% (2  %//% 10)               # 5
1 %//%  2  %//% 10                # 0.05
(1 %//%  2)  %//% 10              # 0.05


require(magrittr)                  # el operador más habitual
1  %>% dxy(.,2)                    # 0.5
1  %>% dxy(2)                      # 0.5
pi %>% cos                         # -1

pi %>% cos  %>% {100 + .}          # 99 uso de lambdas básicas
pi %>% cos  %>% {100+.+.+.+.}      # 96
1  %>% {100 + .} %>% {2*.}         # 202 

pi %>% { x <- cos(.)               # lambda expression multilímea
         ifelse(x < 0, "-","+")
       }                           # "-"

                                   # con todo tipo de objetos de datos
cars %>% as.matrix %>%  head
mh <- cars %>% as.matrix %>%  head # almacena el resultado
mh


mxyz(x,y,z) %::% .:numeric:numeric : numeric  # tipado
mxyz(x,y,z) %when% {
            is.infinite(x) ||
            is.infinite(y)  ||
            is.infinite(z)
            }%as% {
            stop("msg from Laude : Mul by Inf is not allowed ")
            }
mxyz(x,y,z) %when% {
            is.numeric(x)
            !is.bad(c(x,y,z))
            }%as% {
            x*y*z
            }
mxyz(x,y,z) %as% {NaN}

mxyz(3,3,3)                       # 27
mxyz(0,Inf,1)                     # error con mensaje
mxyz("a",3,3)                     # NaN
is.numeric(NaN)                   # TRUE

#---------------------------------------------------------------#

log_it_q <- function(p,q) {
                            ifelse( q/p >= 1, 
                                    log(p/(1-p/q)),
                                    sin(p/q*pi))
                           }

log_it_q(10,100)                  # llamada normal
vlog_id_q <- Vectorize(log_it_q)  # vectorización en una línea
vlog_id_q(10:20, 111:121)         # ok


#---------------------------------------------------------------#

# DEPURACIÓN ESPECÍFICA de lambda.r
debug.lr(mxyz) # monitorear mxyz
debug.lr(div_2) # monitorear div_2
which.debug() # mxyz y div_2 son monitoreados
div_2(1) # abrir el modo de depuración
mxyz("a",1,3) # abrir el modo de depuración
mxyz(Inf,0,0) # abrir el modo de depuración
debug.lr(G_fun) # también funciona con una función
# que no es de lambda.rG_fun()
undebug.lr(div_2)
div_2(1)
undebug.all()
#---------------------------------------------------------------#
