R/l.s.R
In lucas9999/l.s:
# komentarz nowy
# komentarz dodany na githubie
#' Creating data.frame for testing functions purpose. It cointains many elements cauasing problems in processing data. So yout can use it to test functions and code with extremly dirty data.
#'
#' @usage l.s.test_set()
#' @export
l.s.test_set <- function(){
require(ggpllot2)
test <- diamonds
test$ad <- runif(nrow(diamonds))
test$ad1 <- runif(nrow(diamonds))
names(test)[length(test)] <- 'ad'
test$same_braki <- rep(NA, nrow(test))
test$unarne <- rep(1, nrow(test))
test$unarne_z_brakiem <- rep(c(NA, 1), times=ceiling(nrow(test/2) ))[1:nrow(testowy)]
#data
test$data <- as.Date(round(1000*runif(nrow(test))), origin='1970-01-01')
#dataPosix
test$data_posixct <- as.POSIXct(round(10000*runif(nrow(test))), origin='1970-01-01')
#factor-duzo pustych czynnikow
test$factor_nadmiar_poziomow <- factor( sample(c(1,2), size = nrow(test), replace = TRUE) , levels=c(1,2,sample(1:100,size=nrow(test)-2, replace=TRUE)))
test$character <- sample(letters, size = nrow(test), replace = TRUE)
#zmienne factor ktora dopuszczaja NA jako poziom
test$factor_z_NA_level <- addNA(factor(1:nrow(test)))
test
}
#' Detailed metadata about data.frames
#'
#' @usage l.s.metadata.big (df, view=TRUE)
#' @param df
#' @param view logical - if results should be displayd by f:View
#' @examples
#' require(ggplot2)
#' l.s.metadata.big(diamonds, view=FALSE)
#' @export
l.s.metadata.big <- function(df, view=TRUE){
df <- as.data.frame(df)
# if names are proper
poper_names <- str_detect(names(df), '[~!@#%^&*()_+-=;:|]') | str_detect(' ', ' ') | str_detect('rrr', '^[1-9]')
# data type
types <- sapply(df, function(x) class(x))
types_paste <- lapply(types, function(x) paste(x, collapse=', ') )
# duplicates in names
duplicated_names <- duplicated(names(df))
# na
percentage_NA <- sapply(df, function(x) round(100*sum(is.na(x))/nrow(df),2) )
# only NA
only_NA <- sapply(df, function(x) sum(is.na(x))==nrow(df) )
# unary
unary <- sapply(df, function(x) length(unique(x))==1)
# unary with NA
unary_with_NA <- sapply(df, function(x) length(unique(x))==2 & anyNA(x) )
# factor with na as level
factor_with_NA_as_level <- sapply(df, function(x) if(is.factor(x)) (if(NA %in% levels(x)) TRUE else FALSE ) else FALSE)
# levels and values difference
factor_level_values_dif <- sapply(df, function(x) if(is.factor(x)) nlevels(x)-length(unique(x)) else NA )
# examples
examples <- mapply(function(x,y){
if('numeric' %in% y | 'Date' %in% y | 'POSIXct' %in% y | 'POSIXlt' %in% y ){
round(quantile(x, na.rm=TRUE),4)
}else{
count <- sort(table(x), decreasing = TRUE)[1:5]
prop <- round(100*prop.table(count),2)
paste(names(count), count, prop)
}
} , df, types)
result <- cbind(types_paste, poper_names, duplicated_names, percentage_NA, only_NA, unary, unary_with_NA, factor_with_NA_as_level, t(examples))
if(view){
View(result)
}else{
result
}
}
#' Glimps add potencial problems with data.frame.
#'
#' @usage l.s.metadata.small(df)
#' df data.frame
#' @examples
#' require(ggplot2)
#' l.s.metadata.small(df)
#' @export
l.s.metadata.small <- function(df){#!!!!sprawdzic czy ta sama funkcja jest pod spodem inaczej zdefiniowana??????
result <- t(data.frame(
type = class(df),
nrow = nrow(df),
ncol = ncol(df),
object_size = formatC(x=object.size(df)[1], format = "fg", big.mark = ' '),
all_proper_names = all(str_detect(names(df), '[~!@#%^&*()_+-=;:|]') | str_detect(' ', ' ') | str_detect('rrr', '^[1-9]')),
max_percentage_NA = max(sapply(df, function(x) round(100*sum(is.na(x))/nrow(df),2) )),
duplicated_names = any(duplicated(names(df))),
only_NA = any(sapply(df, function(x) sum(is.na(x))==nrow(df))),
unary = any(sapply(df, function(x) length(unique(x))==1)),
unary_with_NA = any(sapply(df, function(x) if(is.factor(x)) (if(NA %in% levels(x)) TRUE else FALSE ) else FALSE)),
factor_with_NA_as_level = any(sapply(df, function(x) if(is.factor(x)) (if(NA %in% levels(x)) TRUE else FALSE ) else FALSE)),
factor_leves_values_diff_max = max(sapply(df, function(x) if(is.factor(x)) nlevels(x)-length(unique(x)) else NA ), na.rm=TRUE)
))
colnames(result) <- 'value'
result
}
# ???
# l.s.metadata.small <- function(df){
# result <- t(data.frame(
# type = class(df),
# nrow = nrow(df),
# ncol = ncol(df),
# object_size = formatC(x=object.size(df)[1], format = "fg", big.mark = ' '),
# all_proper_names = all(str_detect(names(df), '[~!@#%^&*()_+-=;:|]') | str_detect(' ', ' ') | str_detect('rrr', '^[1-9]')),
# max_percentage_NA = max(sapply(df, function(x) round(100*sum(is.na(x))/nrow(df),2) )),
# duplicated_names = any(duplicated(names(df))),
# only_NA = any(sapply(df, function(x) sum(is.na(x))==nrow(df))),
# unary = any(sapply(df, function(x) length(unique(x))==1)),
# unary_with_NA = any(sapply(df, function(x) if(is.factor(x)) (if(NA %in% levels(x)) TRUE else FALSE ) else FALSE)),
# factor_with_NA_as_level = any(sapply(df, function(x) if(is.factor(x)) (if(NA %in% levels(x)) TRUE else FALSE ) else FALSE)),
# factor_leves_values_diff_max = max(sapply(df, function(x) if(is.factor(x)) nlevels(x)-length(unique(x)) else NA ), na.rm=TRUE)
# ))
# colnames(result) <- 'value'
# result
# }
#' Replacing polsich letters with normal letters.
#'
#' @usage l.s.polish_sign_remove(ch)
#' @param ch character vector
#' @export
l.s.polish_sign_remove <- function(ch){
require("gsubfn")
gsubfn('.', list('?'='a', '?'='c', '?'='e', '?'='l', '?'='n', '?'='o', '?'='s', '?'='z', '?'='z',
'?'='A', '?'='C', '?'='E', '?'='L', '?'='N', '?'='O', '?'='S', '?'='Z', '?'='Z'), ch)
}
#' Replace signs which are not allewed in names with 'replace' argument.
#'
#' @usage l.s.special_sign_remove(ch, replace="_")
#' @param ch character vector
#' @param replace character vector. Replacement
#' @seealso l.s.polish_sign_remove
#' @export
l.s.special_sign_remove <- function(ch, replace='_'){
gsubfn('.', list('~'=replace, '`'=replace, '!'=replace, '@'=replace, '#'=replace, '$'=replace, '%'=replace, '^'=replace, '&'=replace, '*'=replace, '('=replace, ')'=replace, '-'=replace, '='=replace, '+'=replace, '['=replace, ']'=replace, '{'=replace, '}'=replace, ';'=replace, ':'=replace, '"'=replace, '?'=replace, '/'=replace, '<'=replace, '>'=replace, ','=replace), ch)
}
#' no description
#'
#' @usage l.s.closest_value(nu_base, nu_find, close_type=c("general","down","up"))
#' @param nu_base numric vector
#' @param nu_find numeric vector
#' @param close_type character vector of lenght 1. Which type of finding use (general, down, up)
#' @examples
#' c1<-c(1,3,5,6,7,10,NA)
#' c2<-c(2,4,5,6,6,10,1,1,12,NA)
#'
#' l.s.closest_value(c2, c1, 'gneral')
#' l.s.closest_value(c2, c1, 'down')
#' l.s.closest_value(c2, c1, 'up')
#' @export
l.s.closest_value <- function(nu_base, nu_find, close_type=c('general','down','up')){
if(close_type=='general'){
nu_find[sapply(nu_base, function(x) which.min(abs(nu_find-x))[1])]
}else if(close_type=='down'){
nu_find[sapply(nu_base, function(x) which.max(ifelse(nu_find-x>0,NA,nu_find-x ))[1])]
}else{
nu_find[sapply(nu_base, function(x) which.min(ifelse(nu_find-x<0,NA,nu_find-x ))[1])]
}
}
#' Find n-th week day in month.
#'
#' @usage l.s.n_th_wday_in_month(year=2000, month=1, day="Monday", nr=1, last=FALSE)
#' @param year numerical, vector o flenfth 1
#' @param month numerica of length 1.
#' @param day character vector. Full english name of day
#' @param nr numerica vector of length 1
#' @param last logical.
#' @examples l.s.n_th_wday_in_month(year=2015, month=2, day='Monday', nr=1, last=TRUE)
#' @export
l.s.n_th_wday_in_month <- function(year=2000, month=1, day='Monday', nr=1, last=FALSE){
require(lubridate)
require(Hmisc)
date <- paste(year,formatC(month,flag = '0', width=2), '01',sep='-')
week_day <- capitalize(tolower(day))
seq_date <- seq(from=as.Date(date), to=ceiling_date(as.Date('2015-02-12'), unit = 'month')-1, by=1 )
data.frame(seq_date=seq_date, wday=wday(seq_date, label = TRUE, abbr = FALSE)) %>% group_by(wday) %>% filter(seq_date==sort(seq_date, decreasing = last)[nr]) %>% filter(wday==week_day) %>% .[[1]]
}
#' No description
#'
#' @usage l.s.num_work_free_days(start=as.Date('2010-01-01'), end=as.Date('2012-01-01'), group_by=c('week', 'month', 'quarter', 'year'), saturdays=TRUE, sundays=TRUE, add=NULL, remove=NULL, free_days=TRUE)
#' @param start Date vector of lendht 1
#' @param end Date Vector of lendth 1
#' @param group_by character vector of lenght 1 with names of time units you want to group by
#' @param saturdays lofical. If Saturadys must be included as work free day
#' @param sundays logical. If Sundays must be included as work free day
#' @param add date vector with dates you want to add as work free days
#' @param remove date vector with dates you to remove from free days
#' @param free_days logical
#' @examples
#' l.s.num_work_free_days(start=as.Date('2010-01-01'), end=as.Date('2012-01-01'), group_by='month', saturdays=TRUE, sundays=TRUE, add=NULL, remove=NULL, free_days=TRUE)
#' @export
l.s.num_work_free_days <- function(start=as.Date('2010-01-01'), end=as.Date('2012-01-01'), group_by=c('week', 'month', 'quarter', 'year'), saturdays=TRUE, sundays=TRUE, add=NULL, remove=NULL, free_days=TRUE){
require(lubridate)
require(dplyr)
require("lazyeval")
seq <- seq(from=start, to=end, by=1)
free_days_ <- if(free_days) as.Date(sapply(seq(year(start), year(end)), function(x) l.s.work_free_days(x)[,1], simplify = TRUE), origin=origin) else as.Date(character(0))
sundays_ <- if(sundays) data.frame(seq=seq, wday=wday(seq), stringsAsFactors = FALSE) %>% filter(wday==1) %>% .[,1] else as.Date(character(0))
saturdays_ <- if(saturdays) data.frame(seq=seq, wday=wday(seq), stringsAsFactors = FALSE) %>% filter(wday==7) %>% .[,1] else as.Date(character(0))
add_ <- if(!is.null(add)) add else as.Date(character(0))
remove_ <- if(!is.null(remove)) remove else as.Date(character(0))
free_days_sundays_saturdays_add_remove <- unique(c(free_days_, sundays_, saturdays_, add_, remove_))
seq_df <- data.frame(seq=seq, year=year(seq), quarter=quarter(seq), month=month(seq), week=week(seq))
free_days_sundays_saturdays_add_remove_df <- data.frame(free=free_days_sundays_saturdays_add_remove, s=1)
w <- left_join(seq_df, free_days_sundays_saturdays_add_remove_df, by=c('seq'='free'))
#del group_by <- 'month'
w1 <- w %>% mutate_(new=interp(~paste0(year, formatC(group, width=2, flag=0)), group=as.name(group_by)))
w2 <- w1 %>% group_by(new) %>% dplyr::summarise(num=n(), sum=sum(s, na.rm=TRUE), sum_m=num-sum)
w2
}
#' If day is work free.
#' date Date vector
#' @usage l.s.is_work_free_day(date="2000-01-01")
#' @examples
#' l.s.is_work_free_day(as.Date(c('2015-05-03','2015-01-12','2015-01-11')))
#' @export
l.s.is_work_free_day <- function(date='2000-01-01'){
if(!is.Date(date)) stop('you have to deliver date type')
free_days <- l.s.work_free_days(year(date))[,1]
sapply(date, function(x) x %in% free_days)
}
#' Extract element from Date type wector.
#'
#' @usage l.s.date_extract_elements(df, year = TRUE, halfyear=FALSE, quarter = TRUE, month = TRUE, two_weeks=FALSE, week=FALSE, month_day = TRUE, year_day = FALSE, week_day = FALSE)
#' @param da Date vector.
#' @param year
#' @param halfyear
#' @param quarter
#' @param month
#' @param two weeks
#' @param week
#' @param month_day
#' @param year_day
#' @param week_day
#' @examples
#' l.s.date_extract_elements(as.Date(sample(1:1000), origin='1970-01-01'))
#' l.s.date_extract_elements(as.Date(sample(1:1000), origin='1970-01-01'), T, T, T, T, T, T, T, T, T )
#' @export
l.s.date_extract_elements <- function(df, year = TRUE, halfyear=FALSE, quarter = TRUE, month = TRUE, two_weeks=FALSE, week=FALSE, month_day = TRUE, year_day = FALSE, week_day = FALSE) {
require(lubridate)
dn <- data.frame(aaa=as.Date(df) ) #ramka w ktorej beda wyciagniete elementy
# z<-as.Date('2014-09-09')
if (class(as.Date(dn[,1])) != "Date") stop("Podana zmienna nie jest typu Date")
if(year){
dn$year <- year(dn[,1])
}
if(quarter){
dn$quarter <- quarters(dn[,1])
}
if(month==T){
dn$month_day <- month(dn[,1])
}
if(month_day){
dn$day <- day(dn[,1])
}
if(halfyear){
dn$halfyear <- ifelse(month(dn[,1])<=6,1,2)
}
if (two_weeks) {
dn$two_weeks <- ifelse(day(dn[,1])>15,1,0)
}
if (week) {
dn$week <- week(dn[,1])
}
if (year_day) {
dn$year_day <- yday(dn[,1])
}
if (week_day) {
dn$week_day <- wday(dn[,1])
}
return(dn[,-1])
} # koniec funkcji
#' Calculate difference between two Date vectors.
#'
#' @usage l.s.date_diff(df, var_1, var_2, minutes=FALSE ,hours=FALSE, days=TRUE, weeks=FALSE, months=FALSE, years=FALSE)
#' @param var_1 name of column with Date vector.
#' @param var_2 name of column with Date vector.
#' @param minutes logical
#' @param hours logical
#' @param days logical
#' @param weeks logical
#' @param months logical
#' @param years logical
#' @export
l.s.date_diff<-function(df,var_1, var_2, days=T, weeks=F, months=T, years=F){
#df - data.frame
#var_1 - pierwsza data
#var_2 - druga data
#months - roznica w miesiacach
#years - roznica w latach
#PAKIETY
require(lubridate)
require(DataCombine)
if(class(df[,var_1])!='Date' & class(df[,var_2])!='Date') stop('Jedna ze zmiennych nie jest typu Date')
if(days==T){
df$diff.days <- as.numeric(difftime(df[, var_1], df[, var_2], units='days'))
}
if(weeks==T){
df$diff.weeks <- as.numeric(difftime(df[, var_1], df[, var_2], units='weeks'))
}
if(months==T){
df$diff.months <- (year(df[, var_1]) * 12 + month(df[, var_1])) - (year(df[, var_2]) * 12 + month(df[, var_2]))
}
if(years==T){
df$diff_years <- year(df[,var_1]) - year(df[,var_2])
}
return(df)
}
#' Sample dates from given interval.
#'
#' @usage l.s.samp_date(interval, size=10, sorted=FALSE, origin="1970-01-01", replace=TRUE)
#' @param interval Vector of length 2. It can be Date, numeric or POSIXct
#' @param size size of sample
#' @param sorted if results should be sorted.
#' @param origin character with date as a origin.
#' @param replace logical.
#' @examples
#' l.s.samp_date(as.Date(c('2017-11-24','2014-11-28')))
#' l.s.samp_date(c(1,30))
#' l.s.samp_date(as.POSIXct(c('2013-11-12 07:45:34','2014-09-23')))
#' @export
l.s.samp_date <- function(interval, size=10, sorted=FALSE, origin='1970-01-01', replace=TRUE){
#ARGUMENTS DESTRIPTION:
#interval - endpoints of the interval - must be Date Class
#size - size of sample
#sorted - if results shoud be sorted ascending
#origin - origin if sample from dates
#replace - if samling with replacement
if( !any(class(interval) %in% c('numeric', 'Date', 'POSIXct')) ) stop('Data type must be one of this one: "numeric", "Date", "POSIXct"')
if(length(interval)!=2) stop('Two endpoints must be given')
endpoints <- as.numeric(sort(interval))
sample <- sample(endpoints[1]:endpoints[2], size = size, replace=replace)
sample <- if(any(class(interval) %in% 'POSIXct')) as.POSIXct(sample, origin=origin) else as.Date(sample, origin=origin)
if(sorted) sample <- sort(sample)
sample
}
#' Get names of objects in nested list. Data.frame is not considered here as list.
#'
#' @usage l.s.list_names(x, parent="")
#' @param x list
#' @param parent
#' @export
l.s.list_names <- function(x, parent=""){
if(!(is.list(x) & !is.data.frame(x)) ) return(parent)
mapply(l.s.list_names, x, paste(parent,names(x),sep="$"), SIMPLIFY=FALSE)
}
l.s.list_list <- function(list_default, list_modification){
#ARGUMENTS DESCRIPTION:
#list with default setting
#list with modifications used to overwrite default list
require(memisc) #for %nin%
l <- list()
l$defalut <- list_default
if(length(list_modification)){
l<-c(l,lapply(list_modification, function(x,y){
x <- c(x, y[which(names(y) %nin% names(x))])
}, y=list_default))
}
return(l)
}
#' Vector work free days (national and religious holidays only) in given year.
#'
#' @usage l.s.work_free_days(year=2000)
#' @param year numeric of length 0
#' @examples
#' l.s.work_free_days(2015)
#' @export
l.s.work_free_days <- function(year=2000){
require(dplyr)
require(lubridate)
if(year<=1582){
A<-15; B<-6
}else if(between(year, 1583, 1699)){
A<-22; B<-2
}else if(between(year, 1700, 1799)){
A<-23; B<-3
}else if(between(year, 1800, 1899)){
A<-23; B<-4
}else if(between(year, 1900, 2099)){
A<-24; B<-5
}else if(between(year, 2100, 2199)){
A<-24; B<-6
}else if(between(year, 2200, 2299)){
A<-25; B<-0
}else if(between(year, 2300, 2399)){
A<-26; B<-1
}else if(between(year, 2400, 2499)){
A<-25; B<-1
}
a <- year %% 19
b <- year %% 4
c <- year %% 7
d <- (a*19 + A) %% 30
e <- (2*b + 4*c + 6*d + B) %% 7
if((d==29 & e==6) | (d==28 & e==6) ){
wielkanoc_1 <- as.Date(paste(year, '03', '22', sep='-')) + d + e - 7
}else{
wielkanoc_1 <- as.Date(paste(year, '03', '22', sep='-')) + d + e
}
wielkanoc_1
wielkanoc_2 <- wielkanoc_1 + 1
zielone_swiatki <- wielkanoc_1 + 49
# swieta wolne od pracy
results <- rbind(
c(paste(year, '01', '01', sep='-'), 'nowy rok'),
c(paste(year, '01', '06', sep='-'), 'trzech kroli'),
c(paste(year, formatC(month(wielkanoc_1), width=2, flag=0), formatC(day(wielkanoc_1), width=2, flag=0), sep='-'), 'pierwszy dzie? wielkiej nocy'),
c(paste(year, formatC(month(wielkanoc_2), width=2, flag=0), formatC(day(wielkanoc_2), width=2, flag=0), sep='-'), 'drugi dzie? wielkiej nocy'),
c(paste(year, '05', '01', sep='-'), 'swieto pracy'),
c(paste(year, '05', '03', sep='-'), 'uchwalenie konstytucji'),
c(paste(year, formatC(month(zielone_swiatki), width=2, flag=0), formatC(day(zielone_swiatki), width=2, flag=0), sep='-'), 'zielone swiatki'),
c(paste(year, '08', '15', sep='-'), 'wniebowziecie'),
c(paste(year, '01', '11', sep='-'), 'wszystkich swientych'),
c(paste(year, '11', '11', sep='-'), 'swieto niepodleglosci'))
results <- as.data.frame(results)
results <- setNames(results, c('date','holiday name'))
results[,1] <- as.Date(results[,1])
results
}
#' Load set of basic packages. Recommendet to use before you start your work for proper order of loading packages.
#'
#' @usage l.s.packages_basic()
#' @export
l.s.packages_basic <- function(){
Sys.setenv(LANG='en') # errors and warning in english - only for current session!!!
#data transform
library(plyr)
library(MASS)
library(mosaic)
library(purrr)
require(rlist)
require(reshape2)
require(DataCombine)
require(data.table)
require(BBmisc)
require(Hmisc)
require(Kmisc)
require(memisc)
require(pipeR)
require(lazyeval)
require(magrittr)
require(testthat)
require(assertthat)
require(dplyr)
#import export data
require(RODBC)
require(openxlsx)
require(excel.link)
require(readr)
require(readxl)
#grahics
require(ggplot2)
require(gridExtra)
require(lattice)
require(wq) #for function layOut
require(DiagrammeR)
require(leaflet)
require(rgl)
require(plot3Drgl)
require(plotrix)
require(scales)
#html
require(ReporteRs)
require(rtable)
require(knitr)
require(xtable)
require(hwriter)
require(DT)
require(formattable)
require(shiny)
require(shinydashboard)
#mine
require(l.a)
require(l.g)
require(l.html)
require(l.shiny)
#other
require(pacman) # for f:l_load
rm('f'); require(pryr)
}
#' Move column in a data.frame.
#'
#' @usage l.s.moveCol(df, tomove, where = "last", ba = NULL)
#' @param df
#' @param tomove
#' @param where
#' @param bf
#' @examples
#' l.s.moveCol(head(diamonds), 'price', 'last')
#' l.s.moveCol(head(diamonds), 'price', 'first')
#' l.s.moveCol(head(diamonds), 'price', 'before', 'y')
#' l.s.moveCol(head(diamonds), 'price', 'after', 'y')
#' l.s.moveCol(head(diamonds), c('price','carat'), 'after', 'y')
#' @export
l.s.moveCol <- function(df, tomove, where = "last", bf = NULL){
temp <- setdiff(names(df), tomove)
x <- switch(
where,
first = df[c(tomove, temp)],
last = df[c(temp, tomove)],
before = {
if (is.null(bf)) stop("must specify ba column")
if (length(bf) > 1) stop("ba must be a single character string")
df[append(temp, values = tomove, after = (match(bf, temp)-1))]
},
after = {
if (is.null(bf)) stop("must specify ba column")
if (length(bf) > 1) stop("ba must be a single character string")
df[append(temp, values = tomove, after = (match(bf, temp)))]
})
x
}
#' Instead this function it is better (in the case of numbers) to use this syntax: formatC(23, digits = 0, flag = 0, width = 10, format = 'f')
#'
#' @usage l.s.wypelniacz(ve, how_many, sign)
#' @examples
#' z <- c('a','aa','a','','aaa','aaaaa')
#' w <- 'x'
#' l.s.wypelniacz(ve=z, how_many=6, sign=w)
#' @export
l.s.wypelniacz <- function(ve, how_many, sign){
#dn-wektor dowolnego typu
#ile-ile do wypelnienia
#znak-znak jaki ma posluzyc do wypelenienia
#sprawdzam czy max dlugosc znakow nie przekrzacza parametru 'ile'
if(max(nchar(ve)) > how_many ) stop('Ilosc znakow przekracza wskaznik wypelnienia')
z <- how_many - nchar(ve)
doklejki <- tapply(X = z , INDEX = 1:length(z) , FUN = function(x) {
paste(rep(sign, x), collapse='')
}, simplify=TRUE)
wynik <- paste(doklejki, ve, sep='')
return(wynik)
}
#' Build date (not data!) from extracted elements in given order.
#'
#' @usage l.s.date_builder(zm ,c, sep='')
#' @param zm
#' @param c numeric. Order of elements. Empty mean omitting element
#' @param sep
#' @examples
#' zm <- seq(as.Date('2012-09-06'),as.Date('2015-12-23'), by='months'
#' sep=''
#' c=c('1','','3','','','','4','','')
#' l.s.date_builder(zm ,c, sep)
#' @export
l.s.date_builder <- function(zm ,c, sep=''){
#zmienna (wektor)-nazwa nowej zmiennej
#wektor (wektor) - wektor z informacjami o uzyciu elementow do budowy nowej zmiennej
#sprawdzam litery
z1 <- is.na(as.numeric(c)) #wektor przy przeksztalacaniu na numeric wprowadza NA gdzie nie sa sie przeksztalcic (wywali ostrzezenie ale nie error)
#sprawdzam puste
z2 <- c==''
#zapelniam liczba 99 puste i te z literami
c[z1 | z2] <- 99
#sprawdzam duplikaty
z3<-duplicated(c)
c[z3] <- 99
il <- length(c[c!=99])
if(il==0 | class(zm)!='Date'){
return(NULL)
}else{
k <- list()
for(i in 1:il){
#i=4
w <- sort(c)[i]
w1 <- match(w,c)
require(lubridate)
if(w1==1){ #rok
k[[i]] <- year(zm)
}else if(w1==2){ #polrocze
k[[i]] <- ifelse(months(zm) < 7, 1, 2)
}else if(w1==3){ #kwartal
k[[i]] <- quarters(zm)
}else if(w1==4){ #miesiac
k[[i]]<-l.s.wypelniacz(ve = month(zm), how_many = 2, sign = 0)
}else if(w1==5){ #dwutydzien
k[[i]] <- ifelse(days(zm) > 14, 2, 1)
}else if(w1==6){ #tydzien
k[[i]] <- l.s.wypelniacz(ve = week(zm), how_many = 2, sign = 0)
}else if(w1==7){ #dzien miesiaca
k[[i]] <- l.s.wypelniacz(ve = day(zm), how_many = 2, sign = 0)
}else if(w1==8){ #dzien roku
k[[i]] <- l.s.wypelniacz(ve = yday(zm), how_many = 3, sing = 0)
}else if(w1==9){ #dzien tygodnia
k[[i]] <- wday(zm)
}else{
}
z <- do.call('paste', c(k, sep=sep))
}
return(z)
}
}
#' All duplicated row (albo first row in group)
#'
#' @usage l.s.dup_full(df=NULL, keys=NULL, include_na=TRUE)
#' @param df
#' @param keys
#' @param include_na
#' @examples
#' dane <- data.frame(a=c(1,1,1,2,2,3,3,3,NA,NA,NA,10,11,12,12), c=1:15)
#' l.s.dup_full(dane, 'a', FALSE)
#' l.s.dup_full(dane, 'a', TRUE)
#' @export
l.s.dup_full <- function(df=NULL, keys=NULL, include_na=TRUE) {
require(DataCombine)
# chcecking if keys and df is not null
if(is.null(df) | is.null(keys)) stop('you have to provide df and keys')
# checking if df is data.frame
if(!'data.frame' %in% class(df)) stop('df is not a data.frame')
# checking if df contains keys columns
if(!all(keys %in% names(df) )) stop("df does not cointain all keys")
if(!include_na){
df <- DataCombine::DropNA(df, keys)
df[duplicated(df[,keys]) | duplicated(df[,keys], fromLast=TRUE),]
}else{
df[duplicated(df[,keys]) | duplicated(df[,keys], fromLast=TRUE),]
}
}
#' Consecutive elements in sequence
#'
#' @usage l.s.consec(x=NULL, value=0)
#' @param x - vector
#' @param value
#' @examples
#' l.s.consec(z, 1)
#' z <- c(1,1,1,0,0,0,0,0,1,1,1,0,0,1,1)
#' @export
l.s.consec <- function(x=NULL, value=0){
x <- x==value
tmp <- cumsum(x);
tmp - cummax((!x)*tmp)
}
#' export to excel usint p:excel.link
#'
#' @usage l.s.e(dn,new=T,naz=NULL)
#' @param dn
#' @param new
#' @param name
#' @export
l.s.e<-function(dn,new=T,name=NULL){ #x-tablica lub wektor, z-czy dodac nowy plik czy tez nowy arkusz, k-adres komorki
#dn-data set
#new-if you want to create new file (if not only new worksheet is created)
#name-name of new worksheet
require(excel.link)
if(new==T){
xl.workbook.add()
}else{
xl.sheet.add(xl.sheet.name=name)
}
xlrc[a1] <- dn
}
#' import data from excel using p:excel.link
#'
#' @usage l.s.i(reg='a1', na='', row_names=FALSE, col_names=TRUE)
#' @param reg
#' @param na
#' @param row_names
#' @param col_names
#' @examples
#' data_from_excel <- l.p.i('a1')
#' @export
l.s.i <- function(reg='a1', na='', row_names=FALSE, col_names=TRUE){
#reg-komorka w gornym lewym rogu tabeli
#na-jak zapisane sa braki danych
#row_names-czy nazwy wierszy
#col_names-czy nazwy kolumn
require(excel.link)
return(xl.current.region(
str.rng=reg,
row.names=row_names,
col.names=col_names,
na=na))
}
#' round numbers like excel
#'
#' @usage l.s.round_excel(x, digits=0)
#' @param x
#' @param digits
#' @examples
#' l.s.round_excel(.5)
#' @export
l.s.round_excel <- function(x, digits=0) {
factor <- 10^digits
trunc(x*factor + 0.5)/factor
}
#' detph of the list
#'
#' @usage l.s.list_depth(this, thisdepth = 0)
#' @param x
#' @param thisdepth
#' @examples
#' lista <- list(a=10, b=list(c=10, d=list(e=20, f=list(g=30))))
#' l.s.list_depth(lista)
#' @export
l.s.list_depth <- function(this, thisdepth = 0) {
if(!is.list(this) | is.data.frame(this)) {
return(thisdepth)
} else {
return(max(unlist(lapply(this, l.s.list_depth, thisdepth = thisdepth+1))))
}
}
lucas9999/l.s documentation built on May 21, 2019, 8:53 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
# komentarz nowy
# komentarz dodany na githubie
#' Creating data.frame for testing functions purpose. It cointains many elements cauasing problems in processing data. So yout can use it to test functions and code with extremly dirty data.
#'
#' @usage l.s.test_set()
#' @export
l.s.test_set <- function(){
require(ggpllot2)
test <- diamonds
test$ad <- runif(nrow(diamonds))
test$ad1 <- runif(nrow(diamonds))
names(test)[length(test)] <- 'ad'
test$same_braki <- rep(NA, nrow(test))
test$unarne <- rep(1, nrow(test))
test$unarne_z_brakiem <- rep(c(NA, 1), times=ceiling(nrow(test/2) ))[1:nrow(testowy)]
#data
test$data <- as.Date(round(1000*runif(nrow(test))), origin='1970-01-01')
#dataPosix
test$data_posixct <- as.POSIXct(round(10000*runif(nrow(test))), origin='1970-01-01')
#factor-duzo pustych czynnikow
test$factor_nadmiar_poziomow <- factor( sample(c(1,2), size = nrow(test), replace = TRUE) , levels=c(1,2,sample(1:100,size=nrow(test)-2, replace=TRUE)))
test$character <- sample(letters, size = nrow(test), replace = TRUE)
#zmienne factor ktora dopuszczaja NA jako poziom
test$factor_z_NA_level <- addNA(factor(1:nrow(test)))
test
}
#' Detailed metadata about data.frames
#'
#' @usage l.s.metadata.big (df, view=TRUE)
#' @param df
#' @param view logical - if results should be displayd by f:View
#' @examples
#' require(ggplot2)
#' l.s.metadata.big(diamonds, view=FALSE)
#' @export
l.s.metadata.big <- function(df, view=TRUE){
df <- as.data.frame(df)
# if names are proper
poper_names <- str_detect(names(df), '[~!@#%^&*()_+-=;:|]') | str_detect(' ', ' ') | str_detect('rrr', '^[1-9]')
# data type
types <- sapply(df, function(x) class(x))
types_paste <- lapply(types, function(x) paste(x, collapse=', ') )
# duplicates in names
duplicated_names <- duplicated(names(df))
# na
percentage_NA <- sapply(df, function(x) round(100*sum(is.na(x))/nrow(df),2) )
# only NA
only_NA <- sapply(df, function(x) sum(is.na(x))==nrow(df) )
# unary
unary <- sapply(df, function(x) length(unique(x))==1)
# unary with NA
unary_with_NA <- sapply(df, function(x) length(unique(x))==2 & anyNA(x) )
# factor with na as level
factor_with_NA_as_level <- sapply(df, function(x) if(is.factor(x)) (if(NA %in% levels(x)) TRUE else FALSE ) else FALSE)
# levels and values difference
factor_level_values_dif <- sapply(df, function(x) if(is.factor(x)) nlevels(x)-length(unique(x)) else NA )
# examples
examples <- mapply(function(x,y){
if('numeric' %in% y | 'Date' %in% y | 'POSIXct' %in% y | 'POSIXlt' %in% y ){
round(quantile(x, na.rm=TRUE),4)
}else{
count <- sort(table(x), decreasing = TRUE)[1:5]
prop <- round(100*prop.table(count),2)
paste(names(count), count, prop)
}
} , df, types)
result <- cbind(types_paste, poper_names, duplicated_names, percentage_NA, only_NA, unary, unary_with_NA, factor_with_NA_as_level, t(examples))
if(view){
View(result)
}else{
result
}
}
#' Glimps add potencial problems with data.frame.
#'
#' @usage l.s.metadata.small(df)
#' df data.frame
#' @examples
#' require(ggplot2)
#' l.s.metadata.small(df)
#' @export
l.s.metadata.small <- function(df){#!!!!sprawdzic czy ta sama funkcja jest pod spodem inaczej zdefiniowana??????
result <- t(data.frame(
type = class(df),
nrow = nrow(df),
ncol = ncol(df),
object_size = formatC(x=object.size(df)[1], format = "fg", big.mark = ' '),
all_proper_names = all(str_detect(names(df), '[~!@#%^&*()_+-=;:|]') | str_detect(' ', ' ') | str_detect('rrr', '^[1-9]')),
max_percentage_NA = max(sapply(df, function(x) round(100*sum(is.na(x))/nrow(df),2) )),
duplicated_names = any(duplicated(names(df))),
only_NA = any(sapply(df, function(x) sum(is.na(x))==nrow(df))),
unary = any(sapply(df, function(x) length(unique(x))==1)),
unary_with_NA = any(sapply(df, function(x) if(is.factor(x)) (if(NA %in% levels(x)) TRUE else FALSE ) else FALSE)),
factor_with_NA_as_level = any(sapply(df, function(x) if(is.factor(x)) (if(NA %in% levels(x)) TRUE else FALSE ) else FALSE)),
factor_leves_values_diff_max = max(sapply(df, function(x) if(is.factor(x)) nlevels(x)-length(unique(x)) else NA ), na.rm=TRUE)
))
colnames(result) <- 'value'
result
}
# ???
# l.s.metadata.small <- function(df){
# result <- t(data.frame(
# type = class(df),
# nrow = nrow(df),
# ncol = ncol(df),
# object_size = formatC(x=object.size(df)[1], format = "fg", big.mark = ' '),
# all_proper_names = all(str_detect(names(df), '[~!@#%^&*()_+-=;:|]') | str_detect(' ', ' ') | str_detect('rrr', '^[1-9]')),
# max_percentage_NA = max(sapply(df, function(x) round(100*sum(is.na(x))/nrow(df),2) )),
# duplicated_names = any(duplicated(names(df))),
# only_NA = any(sapply(df, function(x) sum(is.na(x))==nrow(df))),
# unary = any(sapply(df, function(x) length(unique(x))==1)),
# unary_with_NA = any(sapply(df, function(x) if(is.factor(x)) (if(NA %in% levels(x)) TRUE else FALSE ) else FALSE)),
# factor_with_NA_as_level = any(sapply(df, function(x) if(is.factor(x)) (if(NA %in% levels(x)) TRUE else FALSE ) else FALSE)),
# factor_leves_values_diff_max = max(sapply(df, function(x) if(is.factor(x)) nlevels(x)-length(unique(x)) else NA ), na.rm=TRUE)
# ))
# colnames(result) <- 'value'
# result
# }
#' Replacing polsich letters with normal letters.
#'
#' @usage l.s.polish_sign_remove(ch)
#' @param ch character vector
#' @export
l.s.polish_sign_remove <- function(ch){
require("gsubfn")
gsubfn('.', list('?'='a', '?'='c', '?'='e', '?'='l', '?'='n', '?'='o', '?'='s', '?'='z', '?'='z',
'?'='A', '?'='C', '?'='E', '?'='L', '?'='N', '?'='O', '?'='S', '?'='Z', '?'='Z'), ch)
}
#' Replace signs which are not allewed in names with 'replace' argument.
#'
#' @usage l.s.special_sign_remove(ch, replace="_")
#' @param ch character vector
#' @param replace character vector. Replacement
#' @seealso l.s.polish_sign_remove
#' @export
l.s.special_sign_remove <- function(ch, replace='_'){
gsubfn('.', list('~'=replace, '`'=replace, '!'=replace, '@'=replace, '#'=replace, '$'=replace, '%'=replace, '^'=replace, '&'=replace, '*'=replace, '('=replace, ')'=replace, '-'=replace, '='=replace, '+'=replace, '['=replace, ']'=replace, '{'=replace, '}'=replace, ';'=replace, ':'=replace, '"'=replace, '?'=replace, '/'=replace, '<'=replace, '>'=replace, ','=replace), ch)
}
#' no description
#'
#' @usage l.s.closest_value(nu_base, nu_find, close_type=c("general","down","up"))
#' @param nu_base numric vector
#' @param nu_find numeric vector
#' @param close_type character vector of lenght 1. Which type of finding use (general, down, up)
#' @examples
#' c1<-c(1,3,5,6,7,10,NA)
#' c2<-c(2,4,5,6,6,10,1,1,12,NA)
#'
#' l.s.closest_value(c2, c1, 'gneral')
#' l.s.closest_value(c2, c1, 'down')
#' l.s.closest_value(c2, c1, 'up')
#' @export
l.s.closest_value <- function(nu_base, nu_find, close_type=c('general','down','up')){
if(close_type=='general'){
nu_find[sapply(nu_base, function(x) which.min(abs(nu_find-x))[1])]
}else if(close_type=='down'){
nu_find[sapply(nu_base, function(x) which.max(ifelse(nu_find-x>0,NA,nu_find-x ))[1])]
}else{
nu_find[sapply(nu_base, function(x) which.min(ifelse(nu_find-x<0,NA,nu_find-x ))[1])]
}
}
#' Find n-th week day in month.
#'
#' @usage l.s.n_th_wday_in_month(year=2000, month=1, day="Monday", nr=1, last=FALSE)
#' @param year numerical, vector o flenfth 1
#' @param month numerica of length 1.
#' @param day character vector. Full english name of day
#' @param nr numerica vector of length 1
#' @param last logical.
#' @examples l.s.n_th_wday_in_month(year=2015, month=2, day='Monday', nr=1, last=TRUE)
#' @export
l.s.n_th_wday_in_month <- function(year=2000, month=1, day='Monday', nr=1, last=FALSE){
require(lubridate)
require(Hmisc)
date <- paste(year,formatC(month,flag = '0', width=2), '01',sep='-')
week_day <- capitalize(tolower(day))
seq_date <- seq(from=as.Date(date), to=ceiling_date(as.Date('2015-02-12'), unit = 'month')-1, by=1 )
data.frame(seq_date=seq_date, wday=wday(seq_date, label = TRUE, abbr = FALSE)) %>% group_by(wday) %>% filter(seq_date==sort(seq_date, decreasing = last)[nr]) %>% filter(wday==week_day) %>% .[[1]]
}
#' No description
#'
#' @usage l.s.num_work_free_days(start=as.Date('2010-01-01'), end=as.Date('2012-01-01'), group_by=c('week', 'month', 'quarter', 'year'), saturdays=TRUE, sundays=TRUE, add=NULL, remove=NULL, free_days=TRUE)
#' @param start Date vector of lendht 1
#' @param end Date Vector of lendth 1
#' @param group_by character vector of lenght 1 with names of time units you want to group by
#' @param saturdays lofical. If Saturadys must be included as work free day
#' @param sundays logical. If Sundays must be included as work free day
#' @param add date vector with dates you want to add as work free days
#' @param remove date vector with dates you to remove from free days
#' @param free_days logical
#' @examples
#' l.s.num_work_free_days(start=as.Date('2010-01-01'), end=as.Date('2012-01-01'), group_by='month', saturdays=TRUE, sundays=TRUE, add=NULL, remove=NULL, free_days=TRUE)
#' @export
l.s.num_work_free_days <- function(start=as.Date('2010-01-01'), end=as.Date('2012-01-01'), group_by=c('week', 'month', 'quarter', 'year'), saturdays=TRUE, sundays=TRUE, add=NULL, remove=NULL, free_days=TRUE){
require(lubridate)
require(dplyr)
require("lazyeval")
seq <- seq(from=start, to=end, by=1)
free_days_ <- if(free_days) as.Date(sapply(seq(year(start), year(end)), function(x) l.s.work_free_days(x)[,1], simplify = TRUE), origin=origin) else as.Date(character(0))
sundays_ <- if(sundays) data.frame(seq=seq, wday=wday(seq), stringsAsFactors = FALSE) %>% filter(wday==1) %>% .[,1] else as.Date(character(0))
saturdays_ <- if(saturdays) data.frame(seq=seq, wday=wday(seq), stringsAsFactors = FALSE) %>% filter(wday==7) %>% .[,1] else as.Date(character(0))
add_ <- if(!is.null(add)) add else as.Date(character(0))
remove_ <- if(!is.null(remove)) remove else as.Date(character(0))
free_days_sundays_saturdays_add_remove <- unique(c(free_days_, sundays_, saturdays_, add_, remove_))
seq_df <- data.frame(seq=seq, year=year(seq), quarter=quarter(seq), month=month(seq), week=week(seq))
free_days_sundays_saturdays_add_remove_df <- data.frame(free=free_days_sundays_saturdays_add_remove, s=1)
w <- left_join(seq_df, free_days_sundays_saturdays_add_remove_df, by=c('seq'='free'))
#del group_by <- 'month'
w1 <- w %>% mutate_(new=interp(~paste0(year, formatC(group, width=2, flag=0)), group=as.name(group_by)))
w2 <- w1 %>% group_by(new) %>% dplyr::summarise(num=n(), sum=sum(s, na.rm=TRUE), sum_m=num-sum)
w2
}
#' If day is work free.
#' date Date vector
#' @usage l.s.is_work_free_day(date="2000-01-01")
#' @examples
#' l.s.is_work_free_day(as.Date(c('2015-05-03','2015-01-12','2015-01-11')))
#' @export
l.s.is_work_free_day <- function(date='2000-01-01'){
if(!is.Date(date)) stop('you have to deliver date type')
free_days <- l.s.work_free_days(year(date))[,1]
sapply(date, function(x) x %in% free_days)
}
#' Extract element from Date type wector.
#'
#' @usage l.s.date_extract_elements(df, year = TRUE, halfyear=FALSE, quarter = TRUE, month = TRUE, two_weeks=FALSE, week=FALSE, month_day = TRUE, year_day = FALSE, week_day = FALSE)
#' @param da Date vector.
#' @param year
#' @param halfyear
#' @param quarter
#' @param month
#' @param two weeks
#' @param week
#' @param month_day
#' @param year_day
#' @param week_day
#' @examples
#' l.s.date_extract_elements(as.Date(sample(1:1000), origin='1970-01-01'))
#' l.s.date_extract_elements(as.Date(sample(1:1000), origin='1970-01-01'), T, T, T, T, T, T, T, T, T )
#' @export
l.s.date_extract_elements <- function(df, year = TRUE, halfyear=FALSE, quarter = TRUE, month = TRUE, two_weeks=FALSE, week=FALSE, month_day = TRUE, year_day = FALSE, week_day = FALSE) {
require(lubridate)
dn <- data.frame(aaa=as.Date(df) ) #ramka w ktorej beda wyciagniete elementy
# z<-as.Date('2014-09-09')
if (class(as.Date(dn[,1])) != "Date") stop("Podana zmienna nie jest typu Date")
if(year){
dn$year <- year(dn[,1])
}
if(quarter){
dn$quarter <- quarters(dn[,1])
}
if(month==T){
dn$month_day <- month(dn[,1])
}
if(month_day){
dn$day <- day(dn[,1])
}
if(halfyear){
dn$halfyear <- ifelse(month(dn[,1])<=6,1,2)
}
if (two_weeks) {
dn$two_weeks <- ifelse(day(dn[,1])>15,1,0)
}
if (week) {
dn$week <- week(dn[,1])
}
if (year_day) {
dn$year_day <- yday(dn[,1])
}
if (week_day) {
dn$week_day <- wday(dn[,1])
}
return(dn[,-1])
} # koniec funkcji
#' Calculate difference between two Date vectors.
#'
#' @usage l.s.date_diff(df, var_1, var_2, minutes=FALSE ,hours=FALSE, days=TRUE, weeks=FALSE, months=FALSE, years=FALSE)
#' @param var_1 name of column with Date vector.
#' @param var_2 name of column with Date vector.
#' @param minutes logical
#' @param hours logical
#' @param days logical
#' @param weeks logical
#' @param months logical
#' @param years logical
#' @export
l.s.date_diff<-function(df,var_1, var_2, days=T, weeks=F, months=T, years=F){
#df - data.frame
#var_1 - pierwsza data
#var_2 - druga data
#months - roznica w miesiacach
#years - roznica w latach
#PAKIETY
require(lubridate)
require(DataCombine)
if(class(df[,var_1])!='Date' & class(df[,var_2])!='Date') stop('Jedna ze zmiennych nie jest typu Date')
if(days==T){
df$diff.days <- as.numeric(difftime(df[, var_1], df[, var_2], units='days'))
}
if(weeks==T){
df$diff.weeks <- as.numeric(difftime(df[, var_1], df[, var_2], units='weeks'))
}
if(months==T){
df$diff.months <- (year(df[, var_1]) * 12 + month(df[, var_1])) - (year(df[, var_2]) * 12 + month(df[, var_2]))
}
if(years==T){
df$diff_years <- year(df[,var_1]) - year(df[,var_2])
}
return(df)
}
#' Sample dates from given interval.
#'
#' @usage l.s.samp_date(interval, size=10, sorted=FALSE, origin="1970-01-01", replace=TRUE)
#' @param interval Vector of length 2. It can be Date, numeric or POSIXct
#' @param size size of sample
#' @param sorted if results should be sorted.
#' @param origin character with date as a origin.
#' @param replace logical.
#' @examples
#' l.s.samp_date(as.Date(c('2017-11-24','2014-11-28')))
#' l.s.samp_date(c(1,30))
#' l.s.samp_date(as.POSIXct(c('2013-11-12 07:45:34','2014-09-23')))
#' @export
l.s.samp_date <- function(interval, size=10, sorted=FALSE, origin='1970-01-01', replace=TRUE){
#ARGUMENTS DESTRIPTION:
#interval - endpoints of the interval - must be Date Class
#size - size of sample
#sorted - if results shoud be sorted ascending
#origin - origin if sample from dates
#replace - if samling with replacement
if( !any(class(interval) %in% c('numeric', 'Date', 'POSIXct')) ) stop('Data type must be one of this one: "numeric", "Date", "POSIXct"')
if(length(interval)!=2) stop('Two endpoints must be given')
endpoints <- as.numeric(sort(interval))
sample <- sample(endpoints[1]:endpoints[2], size = size, replace=replace)
sample <- if(any(class(interval) %in% 'POSIXct')) as.POSIXct(sample, origin=origin) else as.Date(sample, origin=origin)
if(sorted) sample <- sort(sample)
sample
}
#' Get names of objects in nested list. Data.frame is not considered here as list.
#'
#' @usage l.s.list_names(x, parent="")
#' @param x list
#' @param parent
#' @export
l.s.list_names <- function(x, parent=""){
if(!(is.list(x) & !is.data.frame(x)) ) return(parent)
mapply(l.s.list_names, x, paste(parent,names(x),sep="$"), SIMPLIFY=FALSE)
}
l.s.list_list <- function(list_default, list_modification){
#ARGUMENTS DESCRIPTION:
#list with default setting
#list with modifications used to overwrite default list
require(memisc) #for %nin%
l <- list()
l$defalut <- list_default
if(length(list_modification)){
l<-c(l,lapply(list_modification, function(x,y){
x <- c(x, y[which(names(y) %nin% names(x))])
}, y=list_default))
}
return(l)
}
#' Vector work free days (national and religious holidays only) in given year.
#'
#' @usage l.s.work_free_days(year=2000)
#' @param year numeric of length 0
#' @examples
#' l.s.work_free_days(2015)
#' @export
l.s.work_free_days <- function(year=2000){
require(dplyr)
require(lubridate)
if(year<=1582){
A<-15; B<-6
}else if(between(year, 1583, 1699)){
A<-22; B<-2
}else if(between(year, 1700, 1799)){
A<-23; B<-3
}else if(between(year, 1800, 1899)){
A<-23; B<-4
}else if(between(year, 1900, 2099)){
A<-24; B<-5
}else if(between(year, 2100, 2199)){
A<-24; B<-6
}else if(between(year, 2200, 2299)){
A<-25; B<-0
}else if(between(year, 2300, 2399)){
A<-26; B<-1
}else if(between(year, 2400, 2499)){
A<-25; B<-1
}
a <- year %% 19
b <- year %% 4
c <- year %% 7
d <- (a*19 + A) %% 30
e <- (2*b + 4*c + 6*d + B) %% 7
if((d==29 & e==6) | (d==28 & e==6) ){
wielkanoc_1 <- as.Date(paste(year, '03', '22', sep='-')) + d + e - 7
}else{
wielkanoc_1 <- as.Date(paste(year, '03', '22', sep='-')) + d + e
}
wielkanoc_1
wielkanoc_2 <- wielkanoc_1 + 1
zielone_swiatki <- wielkanoc_1 + 49
# swieta wolne od pracy
results <- rbind(
c(paste(year, '01', '01', sep='-'), 'nowy rok'),
c(paste(year, '01', '06', sep='-'), 'trzech kroli'),
c(paste(year, formatC(month(wielkanoc_1), width=2, flag=0), formatC(day(wielkanoc_1), width=2, flag=0), sep='-'), 'pierwszy dzie? wielkiej nocy'),
c(paste(year, formatC(month(wielkanoc_2), width=2, flag=0), formatC(day(wielkanoc_2), width=2, flag=0), sep='-'), 'drugi dzie? wielkiej nocy'),
c(paste(year, '05', '01', sep='-'), 'swieto pracy'),
c(paste(year, '05', '03', sep='-'), 'uchwalenie konstytucji'),
c(paste(year, formatC(month(zielone_swiatki), width=2, flag=0), formatC(day(zielone_swiatki), width=2, flag=0), sep='-'), 'zielone swiatki'),
c(paste(year, '08', '15', sep='-'), 'wniebowziecie'),
c(paste(year, '01', '11', sep='-'), 'wszystkich swientych'),
c(paste(year, '11', '11', sep='-'), 'swieto niepodleglosci'))
results <- as.data.frame(results)
results <- setNames(results, c('date','holiday name'))
results[,1] <- as.Date(results[,1])
results
}
#' Load set of basic packages. Recommendet to use before you start your work for proper order of loading packages.
#'
#' @usage l.s.packages_basic()
#' @export
l.s.packages_basic <- function(){
Sys.setenv(LANG='en') # errors and warning in english - only for current session!!!
#data transform
library(plyr)
library(MASS)
library(mosaic)
library(purrr)
require(rlist)
require(reshape2)
require(DataCombine)
require(data.table)
require(BBmisc)
require(Hmisc)
require(Kmisc)
require(memisc)
require(pipeR)
require(lazyeval)
require(magrittr)
require(testthat)
require(assertthat)
require(dplyr)
#import export data
require(RODBC)
require(openxlsx)
require(excel.link)
require(readr)
require(readxl)
#grahics
require(ggplot2)
require(gridExtra)
require(lattice)
require(wq) #for function layOut
require(DiagrammeR)
require(leaflet)
require(rgl)
require(plot3Drgl)
require(plotrix)
require(scales)
#html
require(ReporteRs)
require(rtable)
require(knitr)
require(xtable)
require(hwriter)
require(DT)
require(formattable)
require(shiny)
require(shinydashboard)
#mine
require(l.a)
require(l.g)
require(l.html)
require(l.shiny)
#other
require(pacman) # for f:l_load
rm('f'); require(pryr)
}
#' Move column in a data.frame.
#'
#' @usage l.s.moveCol(df, tomove, where = "last", ba = NULL)
#' @param df
#' @param tomove
#' @param where
#' @param bf
#' @examples
#' l.s.moveCol(head(diamonds), 'price', 'last')
#' l.s.moveCol(head(diamonds), 'price', 'first')
#' l.s.moveCol(head(diamonds), 'price', 'before', 'y')
#' l.s.moveCol(head(diamonds), 'price', 'after', 'y')
#' l.s.moveCol(head(diamonds), c('price','carat'), 'after', 'y')
#' @export
l.s.moveCol <- function(df, tomove, where = "last", bf = NULL){
temp <- setdiff(names(df), tomove)
x <- switch(
where,
first = df[c(tomove, temp)],
last = df[c(temp, tomove)],
before = {
if (is.null(bf)) stop("must specify ba column")
if (length(bf) > 1) stop("ba must be a single character string")
df[append(temp, values = tomove, after = (match(bf, temp)-1))]
},
after = {
if (is.null(bf)) stop("must specify ba column")
if (length(bf) > 1) stop("ba must be a single character string")
df[append(temp, values = tomove, after = (match(bf, temp)))]
})
x
}
#' Instead this function it is better (in the case of numbers) to use this syntax: formatC(23, digits = 0, flag = 0, width = 10, format = 'f')
#'
#' @usage l.s.wypelniacz(ve, how_many, sign)
#' @examples
#' z <- c('a','aa','a','','aaa','aaaaa')
#' w <- 'x'
#' l.s.wypelniacz(ve=z, how_many=6, sign=w)
#' @export
l.s.wypelniacz <- function(ve, how_many, sign){
#dn-wektor dowolnego typu
#ile-ile do wypelnienia
#znak-znak jaki ma posluzyc do wypelenienia
#sprawdzam czy max dlugosc znakow nie przekrzacza parametru 'ile'
if(max(nchar(ve)) > how_many ) stop('Ilosc znakow przekracza wskaznik wypelnienia')
z <- how_many - nchar(ve)
doklejki <- tapply(X = z , INDEX = 1:length(z) , FUN = function(x) {
paste(rep(sign, x), collapse='')
}, simplify=TRUE)
wynik <- paste(doklejki, ve, sep='')
return(wynik)
}
#' Build date (not data!) from extracted elements in given order.
#'
#' @usage l.s.date_builder(zm ,c, sep='')
#' @param zm
#' @param c numeric. Order of elements. Empty mean omitting element
#' @param sep
#' @examples
#' zm <- seq(as.Date('2012-09-06'),as.Date('2015-12-23'), by='months'
#' sep=''
#' c=c('1','','3','','','','4','','')
#' l.s.date_builder(zm ,c, sep)
#' @export
l.s.date_builder <- function(zm ,c, sep=''){
#zmienna (wektor)-nazwa nowej zmiennej
#wektor (wektor) - wektor z informacjami o uzyciu elementow do budowy nowej zmiennej
#sprawdzam litery
z1 <- is.na(as.numeric(c)) #wektor przy przeksztalacaniu na numeric wprowadza NA gdzie nie sa sie przeksztalcic (wywali ostrzezenie ale nie error)
#sprawdzam puste
z2 <- c==''
#zapelniam liczba 99 puste i te z literami
c[z1 | z2] <- 99
#sprawdzam duplikaty
z3<-duplicated(c)
c[z3] <- 99
il <- length(c[c!=99])
if(il==0 | class(zm)!='Date'){
return(NULL)
}else{
k <- list()
for(i in 1:il){
#i=4
w <- sort(c)[i]
w1 <- match(w,c)
require(lubridate)
if(w1==1){ #rok
k[[i]] <- year(zm)
}else if(w1==2){ #polrocze
k[[i]] <- ifelse(months(zm) < 7, 1, 2)
}else if(w1==3){ #kwartal
k[[i]] <- quarters(zm)
}else if(w1==4){ #miesiac
k[[i]]<-l.s.wypelniacz(ve = month(zm), how_many = 2, sign = 0)
}else if(w1==5){ #dwutydzien
k[[i]] <- ifelse(days(zm) > 14, 2, 1)
}else if(w1==6){ #tydzien
k[[i]] <- l.s.wypelniacz(ve = week(zm), how_many = 2, sign = 0)
}else if(w1==7){ #dzien miesiaca
k[[i]] <- l.s.wypelniacz(ve = day(zm), how_many = 2, sign = 0)
}else if(w1==8){ #dzien roku
k[[i]] <- l.s.wypelniacz(ve = yday(zm), how_many = 3, sing = 0)
}else if(w1==9){ #dzien tygodnia
k[[i]] <- wday(zm)
}else{
}
z <- do.call('paste', c(k, sep=sep))
}
return(z)
}
}
#' All duplicated row (albo first row in group)
#'
#' @usage l.s.dup_full(df=NULL, keys=NULL, include_na=TRUE)
#' @param df
#' @param keys
#' @param include_na
#' @examples
#' dane <- data.frame(a=c(1,1,1,2,2,3,3,3,NA,NA,NA,10,11,12,12), c=1:15)
#' l.s.dup_full(dane, 'a', FALSE)
#' l.s.dup_full(dane, 'a', TRUE)
#' @export
l.s.dup_full <- function(df=NULL, keys=NULL, include_na=TRUE) {
require(DataCombine)
# chcecking if keys and df is not null
if(is.null(df) | is.null(keys)) stop('you have to provide df and keys')
# checking if df is data.frame
if(!'data.frame' %in% class(df)) stop('df is not a data.frame')
# checking if df contains keys columns
if(!all(keys %in% names(df) )) stop("df does not cointain all keys")
if(!include_na){
df <- DataCombine::DropNA(df, keys)
df[duplicated(df[,keys]) | duplicated(df[,keys], fromLast=TRUE),]
}else{
df[duplicated(df[,keys]) | duplicated(df[,keys], fromLast=TRUE),]
}
}
#' Consecutive elements in sequence
#'
#' @usage l.s.consec(x=NULL, value=0)
#' @param x - vector
#' @param value
#' @examples
#' l.s.consec(z, 1)
#' z <- c(1,1,1,0,0,0,0,0,1,1,1,0,0,1,1)
#' @export
l.s.consec <- function(x=NULL, value=0){
x <- x==value
tmp <- cumsum(x);
tmp - cummax((!x)*tmp)
}
#' export to excel usint p:excel.link
#'
#' @usage l.s.e(dn,new=T,naz=NULL)
#' @param dn
#' @param new
#' @param name
#' @export
l.s.e<-function(dn,new=T,name=NULL){ #x-tablica lub wektor, z-czy dodac nowy plik czy tez nowy arkusz, k-adres komorki
#dn-data set
#new-if you want to create new file (if not only new worksheet is created)
#name-name of new worksheet
require(excel.link)
if(new==T){
xl.workbook.add()
}else{
xl.sheet.add(xl.sheet.name=name)
}
xlrc[a1] <- dn
}
#' import data from excel using p:excel.link
#'
#' @usage l.s.i(reg='a1', na='', row_names=FALSE, col_names=TRUE)
#' @param reg
#' @param na
#' @param row_names
#' @param col_names
#' @examples
#' data_from_excel <- l.p.i('a1')
#' @export
l.s.i <- function(reg='a1', na='', row_names=FALSE, col_names=TRUE){
#reg-komorka w gornym lewym rogu tabeli
#na-jak zapisane sa braki danych
#row_names-czy nazwy wierszy
#col_names-czy nazwy kolumn
require(excel.link)
return(xl.current.region(
str.rng=reg,
row.names=row_names,
col.names=col_names,
na=na))
}
#' round numbers like excel
#'
#' @usage l.s.round_excel(x, digits=0)
#' @param x
#' @param digits
#' @examples
#' l.s.round_excel(.5)
#' @export
l.s.round_excel <- function(x, digits=0) {
factor <- 10^digits
trunc(x*factor + 0.5)/factor
}
#' detph of the list
#'
#' @usage l.s.list_depth(this, thisdepth = 0)
#' @param x
#' @param thisdepth
#' @examples
#' lista <- list(a=10, b=list(c=10, d=list(e=20, f=list(g=30))))
#' l.s.list_depth(lista)
#' @export
l.s.list_depth <- function(this, thisdepth = 0) {
if(!is.list(this) | is.data.frame(this)) {
return(thisdepth)
} else {
return(max(unlist(lapply(this, l.s.list_depth, thisdepth = thisdepth+1))))
}
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.