Око података.табела

Ова напомена ће бити од интереса за оне који користе табеларну библиотеку за обраду података за Р - дата.табле, и можда ће им бити драго да виде флексибилност њене употребе у различитим примерима.

Инспирисан добрим примером Колеге, и у нади да сте већ прочитали његов чланак, предлажем да копамо дубље у оптимизацију кода и перформансе засноване на подаци.табела.

Увод: Одакле долази дата.табле?

Најбоље је да се упознате са библиотеком мало издалека, наиме, са структурама података из којих се може добити објекат дата.табле (у даљем тексту ДТ).

Арраи

Код

## arrays ---------

arrmatr <- array(1:20, c(4,5))

class(arrmatr)

typeof(arrmatr)

is.array(arrmatr)

is.matrix(arrmatr)

Једна таква структура је низ (?басе::арраи). Као иу другим језицима, низови су и овде вишедимензионални. Међутим, занимљиво је да, на пример, дводимензионални низ почиње да наслеђује својства из матричне класе (?басе::матрик), а једнодимензионални низ, што је такође важно, не наслеђује вектор (?басе::вецтор).

Требало би разумети да тип података садржаних у било ком објекту треба проверити помоћу функције басе::типеоф, који враћа интерни опис типа према Р Интерналс - општи протокол језика који је повезан са оригиналом C.

Друга команда за одређивање класе објекта је база::класа, у случају вектора, враћа тип вектора (по имену се разликује од интерног, али вам такође омогућава да разумете тип података).

Списак

Из дводимензионалног низа, познатог и као матрица, можете ићи на листу (?басе::лист).

Код

## lists ------------------

mylist <- as.list(arrmatr)

is.vector(mylist)

is.list(mylist)

Неколико ствари се дешава одједном:

• Друга димензија матрице се урушава, односно добијамо и листу и вектор у исто време.
• Листа тако наслеђује ове класе. Мора се имати на уму да ће елемент листе одговарати једној (скаларној) вредности из ћелије матрице низа.

Пошто је листа такође вектор, неке векторске функције се могу применити на њу.

Оквир података

Можете ићи са листе, матрице или вектора у оквир података (?басе::дата.фраме).

Код

## data.frames ------------

df <- as.data.frame(arrmatr)
df2 <- as.data.frame(mylist)

is.list(df)

df$V6 <- df$V1 + df$V2

Шта је интересантно у вези са тим: оквир података наслеђује са листе! Колоне оквира података су ћелије листе. Ово ће бити важно касније када будемо користили функције примењене на листе.

подаци.табела

Узми ДТ (?дата.табле::дата.табле) може бити од оквир података, листа, вектор или матрица. На пример, овако (на месту).

Код

## data.tables -----------------------
library(data.table)

data.table::setDT(df)

is.list(df)

is.data.frame(df)

is.data.table(df)

Корисно је да, попут оквира података, ДТ наслеђује својства листе.

ДТ и меморија

За разлику од свих других објеката у Р бази, ДТ се прослеђују референцом. Ако треба да направите копију у нову меморијску област, потребна вам је функција подаци.табела::копија или треба да направите избор из старог објекта.

Код

df2 <- df

df[V1 == 1, V2 := 999]

data.table::fsetdiff(df, df2)

df2 <- data.table::copy(df)

df[V1 == 2, V2 := 999]

data.table::fsetdiff(df, df2)

Овим се завршава увод. ДТ је наставак развоја структура података у Р, који углавном настаје услед проширења и убрзања операција које се обављају на објектима класе датафраме. Истовремено, очувано је наслеђе од других примитиваца.

Неки примери коришћења својстава дата.табле

Као списак...

Итерација преко редова оквира података или ДТ није добра идеја, пошто код петље у језику R много спорије C, али је сасвим могуће проћи кроз колоне, које су обично много мање. Пролазећи кроз колоне, запамтите да је свака колона елемент листе, која обично садржи вектор. А операције над векторима су добро векторизоване у основним функцијама језика. Такође можете да користите операторе избора заједничке за листе и векторе: `[[`, `$`.

Код

## operations on data.tables ------------

#using list properties

df$'V1'[1]

df[['V1']]

df[[1]][1]

sapply(df, class)

sapply(df, function(x) sum(is.na(x)))

Векторизација

Ако постоји потреба да се прође кроз редове великог ДТ, најбоље решење би било написати функцију са векторизацијом. Али ако ово не функционише, треба да запамтите да је циклус унутар ДТ је и даље бржи од циклуса R, пошто се врши на C.

Хајде да пробамо на већем примеру са 100К редова. Прво слово ћемо издвојити из речи укључених у колону вектора w.

Ажурирано

Код

library(magrittr)
library(microbenchmark)

## Bigger example ----

rown <- 100000

dt <- 
	data.table(
		w = sapply(seq_len(rown), function(x) paste(sample(letters, 3, replace = T), collapse = ' '))
		, a = sample(letters, rown, replace = T)
		, b = runif(rown, -3, 3)
		, c = runif(rown, -3, 3)
		, e = rnorm(rown)
	) %>%
	.[, d := 1 + b + c + rnorm(nrow(.))]

# vectorization

microbenchmark({
	dt[
		, first_l := unlist(strsplit(w, split = ' ', fixed = T))[1]
		, by = 1:nrow(dt)
	   ]
})

# second

first_l_f <- function(sd)
{
	strsplit(sd, split = ' ', fixed = T) %>%
		do.call(rbind, .) %>%
		`[`(,1)
}

dt[, first_l := NULL]

microbenchmark({
	dt[
		, first_l := .(first_l_f(w))
		]
})

# third

first_l_f2 <- function(sd)
{
	strsplit(sd, split = ' ', fixed = T) %>%
		unlist %>%
		matrix(nrow = 3) %>%
		`[`(1,)
}

dt[, first_l := NULL]

microbenchmark({
	dt[
		, first_l := .(first_l_f2(w))
		]
})

Прво покрените понављање редова:

Јединица: милисекунде
експр мин
{ дт[, `:=`(први_л, унлист(стрсплит(в, сплит = " ", фиксно = Т))[1]), би = 1:нров(дт)] } 439.6217
лк средња вредност ук мак невал
451.9998 460.1593 456.2505 460.9147 621.4042 100

Друго покретање, где се векторизација дешава претварањем листе у матрицу и узимањем елемената на пресеку са индексом 1 (потоњи је сама векторизација). Исправка: векторизација на нивоу функције стрсплит, који може прихватити вектор као улаз. Испоставило се да је поступак претварања листе у матрицу много тежи од саме векторизације, али је у овом случају много бржи од невекторизоване верзије.

Јединица: милисекунде
експр мин лк средња вредност ук мак невал
{ дт[, `:=`(први_л, .(први_л_ф(в)))] } 93.07916 112.1381 161.9267 149.6863 185.9893 442.5199 100

Убрзање по медијани ин КСНУМКС пута.

Трећа серија, где је промењена шема трансформације у матрицу.

Јединица: милисекунде
експр мин лк средња вредност ук мак невал
{ дт[, `:=`(први_л, .(први_л_ф2(в)))] } 32.60481 34.13679 40.4544 35.57115 42.11975 222.972 100

Убрзање по медијани ин КСНУМКС пута.

Морате експериментисати са овом материјом, што више, то ће бити боље.

Још један пример са векторизацијом, где такође постоји текст, али је близак реалним условима: различите дужине речи, различит број речи. Морате да добијете прве 3 речи. Овако:

Овде претходна функција не ради, пошто су вектори различите дужине, а ми постављамо величину матрице. Хајде да то поновимо копајући по интернету.

Код

# fourth

rown <- 100000

words <-
	sapply(
		seq_len(rown)
		, function(x){
			nwords <- rbinom(1, 10, 0.5)
			paste(
				sapply(
					seq_len(nwords)
					, function(x){
						paste(sample(letters, rbinom(1, 10, 0.5), replace = T), collapse = '')
					}
				)
				, collapse = ' '
			)
		}
	)

dt <- 
	data.table(
		w = words
		, a = sample(letters, rown, replace = T)
		, b = runif(rown, -3, 3)
		, c = runif(rown, -3, 3)
		, e = rnorm(rown)
	) %>%
	.[, d := 1 + b + c + rnorm(nrow(.))]

first_l_f3 <- function(sd, n)
{
	l <- strsplit(sd, split = ' ', fixed = T)
	
	maxl <- max(lengths(l))
	
	sapply(l, "length<-", maxl) %>%
		`[`(n,) %>%
		as.character
}

microbenchmark({
	dt[
		, (paste0('w_', 1:3)) := lapply(1:3, function(x) first_l_f3(w, x))
		]
})

dt[
	, (paste0('w_', 1:3)) := lapply(1:3, function(x) first_l_f3(w, x))
	]

Јединица: милисекунде
експр мин лк средња медијана

{ дт[, `:=`((пасте0(“в_”, 1:3)), стрсплит(в, сплит = " ", фиксно = Т))] } 851.7623 916.071 1054.5 1035.199
ук мак невал
1178.738 1356.816 100

Сценарио је радио просечном брзином од 1 секунде. Није лоше.

Повезани једним ланцем...

Можете радити са ДТ објектима користећи уланчавање. Изгледа као додавање синтаксе заграде на десно, у суштини шећер.

Код

# chaining

res1 <- dt[a == 'a'][sample(.N, 100)]

res2 <- dt[, .N, a][, N]

res3 <- dt[, coefficients(lm(e ~ d))[1], a][, .(letter = a, coef = V1)]

Тече кроз цеви...

Исте операције се могу обавити преко цевовода, изгледа слично, али је функционално богатије, јер можете користити било које методе, не само ДТ. Хајде да изведемо коефицијенте логистичке регресије за наше синтетичке податке са бројним филтерима на ДТ.

Код

# piping

samplpe_b <- dt[a %in% head(letters), sample(b, 1)]

res4 <- 
	dt %>%
	.[a %in% head(letters)] %>%
	.[, 
	  {
	  	dt0 <- .SD[1:100]
	  	
	  	quants <- 
	  		dt0[, c] %>%
	  		quantile(seq(0.1, 1, 0.1), na.rm = T)
	  	
	  	.(q = quants)
	  }
	  , .(cond = b > samplpe_b)
	  ] %>%
	glm(
		cond ~ q -1
		, family = binomial(link = "logit")
		, data = .
	) %>%
	summary %>%
	.[[12]]

Статистика, машинско учење и још много тога унутар ДТ-а

Можете да користите ламбда функције, али понекад је боље да их креирате одвојено, напишете цео цевовод за анализу података и само напред – оне раде унутар ДТ-а. Пример је обогаћен свим горе наведеним карактеристикама, плус неколико корисних ствари из ДТ арсенала (као што је приступ самом ДТ-у унутар ДТ-а преко везе, понекад уметнуте не секвенцијално, већ тако да јесте).

Код

# function

rm(lm_preds)

lm_preds <- function(
	sd, by, n
)
{
	
	if(
		n < 100 | 
		!by[['a']] %in% head(letters, 4)
	   )
	{
		
		res <-
			list(
				low = NA
				, mean = NA
				, high = NA
				, coefs = NA
			)
		
	} else {

		lmm <- 
			lm(
				d ~ c + b
				, data = sd
			)
		
		preds <- 
			stats::predict.lm(
				lmm
				, sd
				, interval = "prediction"
				)
		
		res <-
			list(
				low = preds[, 2]
				, mean = preds[, 1]
				, high = preds[, 3]
				, coefs = coefficients(lmm)
			)
	}

	res
	
}

res5 <- 
	dt %>%
	.[e < 0] %>%
	.[.[, .I[b > 0]]] %>%
	.[, `:=` (
		low = as.numeric(lm_preds(.SD, .BY, .N)[[1]])
		, mean = as.numeric(lm_preds(.SD, .BY, .N)[[2]])
		, high = as.numeric(lm_preds(.SD, .BY, .N)[[3]])
		, coef_c = as.numeric(lm_preds(.SD, .BY, .N)[[4]][1])
		, coef_b = as.numeric(lm_preds(.SD, .BY, .N)[[4]][2])
		, coef_int = as.numeric(lm_preds(.SD, .BY, .N)[[4]][3])
	)
	, a
	] %>%
	.[!is.na(mean), -'e', with = F]


# plot

plo <- 
	res5 %>%
	ggplot +
	facet_wrap(~ a) +
	geom_ribbon(
		aes(
			x = c * coef_c + b * coef_b + coef_int
			, ymin = low
			, ymax = high
			, fill = a
		)
		, size = 0.1
		, alpha = 0.1
	) +
	geom_point(
		aes(
			x = c * coef_c + b * coef_b + coef_int
			, y = mean
			, color = a
		)
		, size = 1
	) +
	geom_point(
		aes(
			x = c * coef_c + b * coef_b + coef_int
			, y = d
		)
		, size = 1
		, color = 'black'
	) +
	theme_minimal()

print(plo)

Закључак

Надам се да сам успео да направим потпуну, али, наравно, не потпуну слику таквог објекта као што је дата.табле, почевши од његових својстава повезаних са наслеђивањем од Р класа и завршавајући сопственим карактеристикама и окружењем од тидиверсе елемената . Надам се да ће вам ово помоћи да боље научите и користите ову библиотеку за рад и забава.

Хвала!

Пун код

Код

## load libs ----------------

library(data.table)
library(ggplot2)
library(magrittr)
library(microbenchmark)


## arrays ---------

arrmatr <- array(1:20, c(4,5))

class(arrmatr)

typeof(arrmatr)

is.array(arrmatr)

is.matrix(arrmatr)


## lists ------------------

mylist <- as.list(arrmatr)

is.vector(mylist)

is.list(mylist)


## data.frames ------------

df <- as.data.frame(arrmatr)

is.list(df)

df$V6 <- df$V1 + df$V2


## data.tables -----------------------

data.table::setDT(df)

is.list(df)

is.data.frame(df)

is.data.table(df)

df2 <- df

df[V1 == 1, V2 := 999]

data.table::fsetdiff(df, df2)

df2 <- data.table::copy(df)

df[V1 == 2, V2 := 999]

data.table::fsetdiff(df, df2)


## operations on data.tables ------------

#using list properties

df$'V1'[1]

df[['V1']]

df[[1]][1]

sapply(df, class)

sapply(df, function(x) sum(is.na(x)))


## Bigger example ----

rown <- 100000

dt <- 
	data.table(
		w = sapply(seq_len(rown), function(x) paste(sample(letters, 3, replace = T), collapse = ' '))
		, a = sample(letters, rown, replace = T)
		, b = runif(rown, -3, 3)
		, c = runif(rown, -3, 3)
		, e = rnorm(rown)
	) %>%
	.[, d := 1 + b + c + rnorm(nrow(.))]

# vectorization

# zero - for loop

microbenchmark({
	for(i in 1:nrow(dt))
		{
		dt[
			i
			, first_l := unlist(strsplit(w, split = ' ', fixed = T))[1]
		]
	}
})

# first

microbenchmark({
	dt[
		, first_l := unlist(strsplit(w, split = ' ', fixed = T))[1]
		, by = 1:nrow(dt)
	   ]
})

# second

first_l_f <- function(sd)
{
	strsplit(sd, split = ' ', fixed = T) %>%
		do.call(rbind, .) %>%
		`[`(,1)
}

dt[, first_l := NULL]

microbenchmark({
	dt[
		, first_l := .(first_l_f(w))
		]
})

# third

first_l_f2 <- function(sd)
{
	strsplit(sd, split = ' ', fixed = T) %>%
		unlist %>%
		matrix(nrow = 3) %>%
		`[`(1,)
}

dt[, first_l := NULL]

microbenchmark({
	dt[
		, first_l := .(first_l_f2(w))
		]
})

# fourth

rown <- 100000

words <-
	sapply(
		seq_len(rown)
		, function(x){
			nwords <- rbinom(1, 10, 0.5)
			paste(
				sapply(
					seq_len(nwords)
					, function(x){
						paste(sample(letters, rbinom(1, 10, 0.5), replace = T), collapse = '')
					}
				)
				, collapse = ' '
			)
		}
	)

dt <- 
	data.table(
		w = words
		, a = sample(letters, rown, replace = T)
		, b = runif(rown, -3, 3)
		, c = runif(rown, -3, 3)
		, e = rnorm(rown)
	) %>%
	.[, d := 1 + b + c + rnorm(nrow(.))]

first_l_f3 <- function(sd, n)
{
	l <- strsplit(sd, split = ' ', fixed = T)
	
	maxl <- max(lengths(l))
	
	sapply(l, "length<-", maxl) %>%
		`[`(n,) %>%
		as.character
}

microbenchmark({
	dt[
		, (paste0('w_', 1:3)) := lapply(1:3, function(x) first_l_f3(w, x))
		]
})

dt[
	, (paste0('w_', 1:3)) := lapply(1:3, function(x) first_l_f3(w, x))
	]


# chaining

res1 <- dt[a == 'a'][sample(.N, 100)]

res2 <- dt[, .N, a][, N]

res3 <- dt[, coefficients(lm(e ~ d))[1], a][, .(letter = a, coef = V1)]

# piping

samplpe_b <- dt[a %in% head(letters), sample(b, 1)]

res4 <- 
	dt %>%
	.[a %in% head(letters)] %>%
	.[, 
	  {
	  	dt0 <- .SD[1:100]
	  	
	  	quants <- 
	  		dt0[, c] %>%
	  		quantile(seq(0.1, 1, 0.1), na.rm = T)
	  	
	  	.(q = quants)
	  }
	  , .(cond = b > samplpe_b)
	  ] %>%
	glm(
		cond ~ q -1
		, family = binomial(link = "logit")
		, data = .
	) %>%
	summary %>%
	.[[12]]


# function

rm(lm_preds)

lm_preds <- function(
	sd, by, n
)
{
	
	if(
		n < 100 | 
		!by[['a']] %in% head(letters, 4)
	   )
	{
		
		res <-
			list(
				low = NA
				, mean = NA
				, high = NA
				, coefs = NA
			)
		
	} else {

		lmm <- 
			lm(
				d ~ c + b
				, data = sd
			)
		
		preds <- 
			stats::predict.lm(
				lmm
				, sd
				, interval = "prediction"
				)
		
		res <-
			list(
				low = preds[, 2]
				, mean = preds[, 1]
				, high = preds[, 3]
				, coefs = coefficients(lmm)
			)
	}

	res
	
}

res5 <- 
	dt %>%
	.[e < 0] %>%
	.[.[, .I[b > 0]]] %>%
	.[, `:=` (
		low = as.numeric(lm_preds(.SD, .BY, .N)[[1]])
		, mean = as.numeric(lm_preds(.SD, .BY, .N)[[2]])
		, high = as.numeric(lm_preds(.SD, .BY, .N)[[3]])
		, coef_c = as.numeric(lm_preds(.SD, .BY, .N)[[4]][1])
		, coef_b = as.numeric(lm_preds(.SD, .BY, .N)[[4]][2])
		, coef_int = as.numeric(lm_preds(.SD, .BY, .N)[[4]][3])
	)
	, a
	] %>%
	.[!is.na(mean), -'e', with = F]


# plot

plo <- 
	res5 %>%
	ggplot +
	facet_wrap(~ a) +
	geom_ribbon(
		aes(
			x = c * coef_c + b * coef_b + coef_int
			, ymin = low
			, ymax = high
			, fill = a
		)
		, size = 0.1
		, alpha = 0.1
	) +
	geom_point(
		aes(
			x = c * coef_c + b * coef_b + coef_int
			, y = mean
			, color = a
		)
		, size = 1
	) +
	geom_point(
		aes(
			x = c * coef_c + b * coef_b + coef_int
			, y = d
		)
		, size = 1
		, color = 'black'
	) +
	theme_minimal()

print(plo)

Извор: ввв.хабр.цом