Commit e75cc48e authored by Virgile Baudrot's avatar Virgile Baudrot
Browse files

Initial commit

parents
# 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:
#
# Build and Reload Package: 'Ctrl + Shift + B'
# Check Package: 'Ctrl + Shift + E'
# Test Package: 'Ctrl + Shift + T'
hello <- function() {
print("Hello, world!")
}
{
"collab_server" : "",
"contents" : "",
"created" : 1570628006523.000,
"dirty" : false,
"encoding" : "UTF-8",
"folds" : "",
"hash" : "0",
"id" : "4421A5C7",
"lastKnownWriteTime" : 1570627550,
"last_content_update" : 1570627550,
"path" : "~/Documents/PACKAGES/fdf/vignettes/start.Rmd",
"project_path" : "vignettes/start.Rmd",
"properties" : {
"chunk_output_type" : "console",
"cursorPosition" : "21,0",
"last_setup_crc32" : "",
"scrollLine" : "0"
},
"relative_order" : 2,
"source_on_save" : false,
"source_window" : "",
"type" : "r_markdown"
}
\ No newline at end of file
---
title: "start"
output: rmarkdown::html_vignette
vignette: >
%\VignetteIndexEntry{start}
%\VignetteEncoding{UTF-8}
%\VignetteEngine{knitr::rmarkdown}
editor_options:
chunk_output_type: console
---
```{r, include = FALSE}
knitr::opts_chunk$set(
collapse = TRUE,
comment = "#>"
)
```
The package `fdf` allow to work with column-list. When for instance you have a list of time series that you want to include in a `data.frame`.
Since it works only with `data.frame` object, there is no new object, you can use very easily with any package like `dplyr` (and the tidyverse) and spatio-temporal object with package `sf` for instance.
```{r setup}
library(fdf)
```
# Add a new column-list with `fd_add`
```{r addData}
DF = data.frame( A = 1:10)
DFD = fd_add(DF, "B", function(i) rnorm(runif(1, 4,20)))
DFD
```
# Filter element in a column-list with `fd_filter`
```{r filter}
fd_filter(DFD, "B", 1)
fd_filter(DFD, "B", 2)
fd_filter(DFD, "B", 3)
```
# Find index of element in column-list matching with a key using `fd_match`
```{r}
DFD = fd_add(DFD, "C", function(i) sample(1:5, 5))
idMatch = fd_match(DFD, "C", 4)
idMatch
# to check this:
fd_filter(DFD, "C", idMatch)
```
# Melting column-list to a classical data.frame with `fd_melt`
```{r meltSimple}
fd_melt(DFD, "B")
fd_melt(DFD, "B", keep = "A")
fd_melt(DFD, "B", keep = list("A", "C"))
```
when two column list have the same length for each elements, we can melt in the same time
```{r meltDouble}
DFD = fd_add(DFD, "B2", function(i) 1:length(DFD$B[[i]]))
fd_melt(DFD, "B", "B2")
fd_melt(DFD, "B", "B2", keep = list("A", "C"))
```
---
title: "start"
output: rmarkdown::html_vignette
vignette: >
%\VignetteIndexEntry{start}
%\VignetteEncoding{UTF-8}
%\VignetteEngine{knitr::rmarkdown}
editor_options:
chunk_output_type: console
---
```{r, include = FALSE}
knitr::opts_chunk$set(
collapse = TRUE,
comment = "#>"
)
```
The package `fdf` allow to work with column-list. When for instance you have a list of time series that you want to include in a `data.frame`.
Since it works only with `data.frame` object, there is no new object, you can use very easily with any package like `dplyr` (and the tidyverse) and spatio-temporal object with package `sf` for instance.
```{r setup}
library(fdf)
```
# Add a new column-list with `fd_add`
```{r addData}
DF = data.frame( A = 1:10)
DFD = fd_add(DF, "B", function(i) rnorm(runif(1, 4,20)))
DFD
```
# Filter element in a column-list with `fd_filter`
```{r filter}
fd_filter(DFD, "B", 1)
fd_filter(DFD, "B", 2)
fd_filter(DFD, "B", 3)
```
# Find index of element in column-list matching with a key using `fd_match`
```{r}
DFD = fd_add(DFD, "C", function(i) sample(1:5, 5))
idMatch = fd_match(DFD, "C", 4)
idMatch
# to check this:
fd_filter(DFD, "C", idMatch)
```
# Melting column-list to a classical data.frame with `fd_melt`
```{r meltSimple}
fd_melt(DFD, "B")
fd_melt(DFD, "B", keep = "A")
fd_melt(DFD, "B", keep = list("A", "C"))
```
when two column list have the same length for each elements, we can melt in the same time
```{r meltDouble}
DFD = fd_add(DFD, "B2", function(i) 1:length(DFD$B[[i]]))
fd_melt(DFD, "B", "B2")
fd_melt(DFD, "B", "B2", keep = list("A", "C"))
```
Package: fdf
Type: Package
Title: Functions for Functional Data Frame
Version: 0.1.0
Author: Virgile Baudrot [aut, cre]
Maintainer: Virgile Baudrot <virgile.baudrot@posteo.net>
Description: A set of function to work with functional data in data frame.
URL: https://gitlab.paca.inra.fr/biosp/fdf
BugReports: https://gitlab.paca.inra.fr/biosp/fdf/issues
License: GPL (>= 2)
Encoding: UTF-8
LazyData: true
Suggests:
knitr,
rmarkdown
VignetteBuilder: knitr
RoxygenNote: 6.1.1
#' @title find index
#'
#' @param x a data.frame
#' @param key character string. name of the column to select
#' @param value value of the element to return index from the column defined by key
#'
#' @return vector if not all index are equal. scalar if all equal.
#'
#' @export
#'
fd_match <- function(x, key, value){
returnID = sapply(1:nrow(x), function(i){ match(value, x[[key]][[i]]) })
if(length(unique(returnID)) == 1){ returnID = unique(returnID) }
return(returnID)
}
#' @title Convert list.column data.frame into scalar.column data.frame
#'
#' @description Convert data.frame with 2 column.list into data.frame with only column.scalar
#'
#' @name fd_melt
#'
#' @param x A data.frame
#' @param key1 character string. The name of the column to select
#' @param key2 icharacter string. The name of the column to select
#' @param id name of the replicate for the id. As to be of the same length as the number of row of the x object
#'
#' @export
#'
fd_melt_DOUBLE <- function(x, key1, key2, id = NULL){
lgth_key1 = sapply(x[[key1]], length)
lgth_key2 = sapply(x[[key2]], length)
if(any(lgth_key1 != lgth_key2)){ stop("length of element from 'key1' and 'key2' differ.")}
if(is.null(id)) {
id = 1:length(lgth_key1)
} else{
id = x[[id]]
}
df = data.frame(
id = do.call("c", lapply(1:length(id), function(i) rep(id[i], lgth_key1[[i]])))
)
df[[key1]] = do.call("c", x[[key1]])
df[[key2]] = do.call("c", x[[key2]])
return(df)
}
#' @name fd_melt
#'
#'
#' @export
#'
fd_melt_SINGLE <- function(x, key1, id = NULL){
lgth_key1 = sapply(x[[key1]], length)
if(is.null(id)) {
id = 1:length(lgth_key1)
} else{
id = x[[id]]
}
df = data.frame(
id = do.call("c", lapply(1:length(id), function(i) rep(id[i], lgth_key1[[i]])))
)
df[[key1]] = do.call("c", x[[key1]])
return(df)
}
#' @name fd_melt
#'
#' @param keep vector of column name to keep
#'
#' @export
#'
fd_melt <- function(x, key1, key2 = NULL, id = NULL, keep = NULL){
if(is.null(key2)){
DF = fd_melt_SINGLE(x, key1, id)
} else{
DF = fd_melt_DOUBLE(x, key1, key2, id)
}
# --- keep
if(!is.null(keep)) {
for(i in 1:length(keep)){
DF[[keep[[i]]]] = fd_melt_STICK(x, key1, keep[[i]])
}
}
return(DF)
}
#' @name fd_melt
#'
#' @export
#'
fd_melt_STICK = function(x, key1, keep){
vec = do.call("c", lapply(1:nrow(x),
function(i){ rep(x[[keep]][i], length(x[[key1]][[i]]))}))
return(vec)
}
#' @title Combine list of data.frame by Rows
#'
#' @description Function used to filter functional data in data.frame.
#'
#' @return Return a data.frame
#'
#' @param ls A list of data.frame
#' @param id id to provide to each data.frame. Must be the length of the list
#'
#' @export
#'
fd_rbindLStoDF <- function(ls, id = NULL){
df <- do.call("rbind", ls)
nrow_df <- sapply(ls, nrow)
if(is.null(id)) { id = 1:length(nrow_df) }
df[["id"]] = do.call("c", lapply(1:length(nrow_df), function(i) rep(id[i], nrow_df[[i]])))
return(df)
}
{
"collab_server" : "",
"contents" : "",
"created" : 1570627938694.000,
"dirty" : false,
"encoding" : "UTF-8",
"folds" : "",
"hash" : "1089222365",
"id" : "E90EAA85",
"lastKnownWriteTime" : 1570627997,
"last_content_update" : 1570627997140,
"path" : "~/Documents/PACKAGES/fdf/DESCRIPTION",
"project_path" : "DESCRIPTION",
"properties" : {
"cursorPosition" : "6,13",
"scrollLine" : "0"
},
"relative_order" : 1,
"source_on_save" : false,
"source_window" : "",
"type" : "dcf"
}
\ No newline at end of file
Package: fdf
Type: Package
Title: Functions for Functional Data Frame
Version: 0.1.0
Author: Virgile Baudrot [aut, cre]
Maintainer: Virgile Baudrot <virgile.baudrot@posteo.net>
Description: A set of functions to work with functional data (column-list) in data frame.
URL: https://gitlab.paca.inra.fr/biosp/fdf
BugReports: https://gitlab.paca.inra.fr/biosp/fdf/issues
License: GPL (>= 2)
Encoding: UTF-8
LazyData: true
Suggests:
knitr,
rmarkdown
VignetteBuilder: knitr
RoxygenNote: 6.1.1
#' @name fd_add
#'
#' @title Add functional data
#'
#' @description Add functional data in data.frame object.
#'
#' @param x object of class data.frame.
#' @param key the name of the new column, as strings or symbols
#' @param FUN the function to be applied to each element of \code{x}.
#' In the case of functions like +, %*%, the function name must be
#' backquoted or quoted. See lapply functions for details.
#' @param \dots optional arguments to FUN. See lapply functions for details.
#'
#' @return An object with addition functional data feature (or feature dynamic).
#'
#' @export
#'
fd_add <- function(x, key, FUN, ...){
x[[key]] <- lapply(1:nrow(x), FUN, ...)
return(x)
}
#' @name fd_add
#'
#' @export
#'
fd_add_NAME <- function(x, key, FUN, ...){
x[[key]] <- lapply(1:nrow(x), FUN, ...)
# class(x) <- c(class(.x), "xfd")
attr(x, "fdFD") <- c(deparse(substitute(key)), attr(x, "fdFD"))
return(x)
}
#' @name fd_add
#'
#' @param keyConstraint character string. The reference of the column to be checked
#'
#' @export
#'
fd_add2 <- function(x, # geometry on which we applied the pollen emission pattern
keyConstraint,
key, # name of the column which is going to be created
FUN,
...){
if("stackTimeline" %in% colnames(x)) {
stop("Please rename column 'stackTimeline' in x object.")
}
# CREATE NEW COLUMN
x[["key_temp"]] <- lapply(1:nrow(x), FUN, ...)
# check length with timeline
if(all(sapply(x[[keyConstraint]], length) != sapply(x[["key_temp"]], length))){
stop(paste0("element within list returned by FUN' has not the same length as list element of '", keyConstraint, "' column"))
}
# ADD StackTimeLine
stackTimeline = sort(unique(do.call("c", x[[keyConstraint]])))
x[[key]] = lapply(1:nrow(x), function(i){
index_matching = match(x[[keyConstraint]][[i]], stackTimeline)
res = rep(0,length(stackTimeline))
res[index_matching] = x[["key_temp"]][[i]]
return(res)
})
# /!\ REPLACE timeline
x[[keyConstraint]] = lapply(1:nrow(x), function(i) stackTimeline)
warning(paste("The column variable", keyConstraint, "may have changed"))
# remove "key_temp"
x[["key_temp"]] = NULL
return(x)
}
#' @name fd_filter
#'
#' @title Function used to filter functional data in data.frame object.
#'
#' @param x a data.frame object.
#' @param key character string. The name of the column to select.
#' @param index integer (or vector). The index of the functional data.
#'
#' @export
#'
fd_filter1 <- function(x, key, index){
x[[key]] <- do.call("c", lapply(x[[key]] , `[[`, index) )
return(x)
}
#' @name fd_filter
#'
#' @export
#'
fd_filter_ <- function(x, key, index){
if(length(index) == 1){ index = rep(index, nrow(x)) }
if(length(index) != nrow(x)){ stop("length of vector index is different of 1 and nrow(x).")}
x[[key]] <- do.call("c", lapply(1:nrow(x), function(i) x[[key]][[i]][index[i]] ))
return(x)
}
#' @name fd_filter
#'
#' @param key1 character string. The name of the column to select
#' @param key2 character string. The name of the column to select
#'
#' @export
#'
fd_filter2 <- function(x, key1, key2, index){
x[[key1]] <- do.call("c", lapply(x[[key1]] , `[[`, index) )
x[[key2]] <- do.call("c", lapply(x[[key2]] , `[[`, index) )
return(x)
}
#' @name fd_filter
#'
#' @param key3 character string. The name of the column to select
#'
#' @export
#'
fd_filter3 <- function(x, key1, key2, key3, index){
x[[key1]] <- do.call("c", lapply(x[[key1]] , `[[`, index) )
x[[key2]] <- do.call("c", lapply(x[[key2]] , `[[`, index) )
x[[key3]] <- do.call("c", lapply(x[[key3]] , `[[`, index) )
return(x)
}
#' @name fd_filter
#'
#' @param keys list of names of the column to select
#'
#' @export
#'
fd_filter <- function(x, keys, index){ # need multi-dispatch !!!!
if(length(index) == 1){ index = rep(index, nrow(x)) }
if(length(index) != nrow(x)){ stop("length of vector index is different of 1 and nrow(x).")}
for(i in 1:length(keys)){
x[[keys[[i]]]] <- do.call("c", lapply(1:nrow(x), function(j) x[[keys[[i]]]][[j]][index[j]] ))
#x[[keys[[i]]]] <- do.call("c", lapply(x[[keys[[i]]]] , `[[`, index[i]) )
}
return(x)
}
{"chunk_definitions":[],"default_chunk_options":{"error":false},"doc_write_time":1570625704,"working_dir":null}
\ No newline at end of file
/home/vbaudrot/Documents/PACKAGES/fdf/DESCRIPTION="28128BA9"
/home/vbaudrot/Documents/PACKAGES/fdf/R/add.R="4D2D17B5"
/home/vbaudrot/Documents/PACKAGES/fdf/R/filter.R="E96533C1"
/home/vbaudrot/Documents/PACKAGES/fdf/R/match.R="CA02FEED"
/home/vbaudrot/Documents/PACKAGES/fdf/R/melt.R="9115648E"
/home/vbaudrot/Documents/PACKAGES/fdf/vignettes/start.Rmd="C55DB299"
inst/doc
Package: fdf
Type: Package
Title: Functions for Functional Data Frame
Version: 0.1.0
Author: Virgile Baudrot [aut, cre]
Maintainer: Virgile Baudrot <virgile.baudrot@posteo.net>
Description: A set of functions to work with functional data (column-list) in data frame.
URL: https://gitlab.paca.inra.fr/biosp/fdf
BugReports: https://gitlab.paca.inra.fr/biosp/fdf/issues
License: GPL (>= 2)
Encoding: UTF-8
LazyData: true
Suggests:
knitr,
rmarkdown
VignetteBuilder: knitr
RoxygenNote: 6.1.1
# Generated by roxygen2: do not edit by hand
export(fd_add)
export(fd_add2)
export(fd_add_NAME)
export(fd_filter)
export(fd_filter1)
export(fd_filter2)
export(fd_filter3)
export(fd_filter_)
export(fd_match)
export(fd_melt)
export(fd_melt_DOUBLE)
export(fd_melt_SINGLE)
export(fd_melt_STICK)
export(fd_rbindLStoDF)
#' @name fd_add
#'
#' @title Add functional data
#'
#' @description Add functional data in data.frame object.
#'
#' @param x object of class data.frame.
#' @param key the name of the new column, as strings or symbols
#' @param FUN the function to be applied to each element of \code{x}.
#' In the case of functions like +, %*%, the function name must be
#' backquoted or quoted. See lapply functions for details.
#' @param \dots optional arguments to FUN. See lapply functions for details.
#'
#' @return An object with addition functional data feature (or feature dynamic).
#'
#' @export
#'
fd_add <- function(x, key, FUN, ...){
x[[key]] <- lapply(1:nrow(x), FUN, ...)
return(x)
}
#' @name fd_add
#'
#' @export
#'
fd_add_NAME <- function(x, key, FUN, ...){
x[[key]] <- lapply(1:nrow(x), FUN, ...)
# class(x) <- c(class(.x), "xfd")
attr(x, "fdFD") <- c(deparse(substitute(key)), attr(x, "fdFD"))
return(x)
}
#' @name fd_add
#'
#' @param keyConstraint character string. The reference of the column to be checked
#'
#' @export
#'
fd_add2 <- function(x, # geometry on which we applied the pollen emission pattern
keyConstraint,
key, # name of the column which is going to be created
FUN,
...){
if("stackTimeline" %in% colnames(x)) {
stop("Please rename column 'stackTimeline' in x object.")
}
# CREATE NEW COLUMN