Skip to content

Commit

Permalink
funkcje do tworzenia zbiorów osobo-miesięcy i przygotowanie do publik…
Browse files Browse the repository at this point in the history
…acji
  • Loading branch information
tzoltak committed Feb 25, 2019
1 parent cf68197 commit e724cde
Show file tree
Hide file tree
Showing 21 changed files with 825 additions and 32 deletions.
3 changes: 3 additions & 0 deletions .Rbuildignore
Original file line number Diff line number Diff line change
@@ -1,7 +1,10 @@
^codecov\.yml$
^\.travis\.yml$
^.*\.Rproj$
^\.Rproj\.user$
^dane$
^doc$
^cache$
^dropbox$
^vignettes/.*_cache$
^data_local/.*$
3 changes: 3 additions & 0 deletions .gitignore
Original file line number Diff line number Diff line change
Expand Up @@ -33,3 +33,6 @@ vignettes/*.dia
*.utf8.md
*.knit.md
.Rproj.user

# test data not to be publicly available
/data_local/
14 changes: 14 additions & 0 deletions .travis.yml
Original file line number Diff line number Diff line change
@@ -0,0 +1,14 @@
# R for travis: see documentation at https://docs.travis-ci.com/user/languages/r

language: R
cache: packages
r:
- release
warnings_are_errors: false
script:
- R CMD build .
- R CMD check *tar.gz --no-tests
notifications:
email:
- [email protected]
- [email protected]
12 changes: 10 additions & 2 deletions NAMESPACE
Original file line number Diff line number Diff line change
@@ -1,18 +1,21 @@
# Generated by roxygen2: do not edit by hand

export(imputuj_mies_pk_1rm)
export(imputuj_mies_pk_pilrm)
export(imputuj_miesiac_pk_1rm)
export(imputuj_miesiac_pk_pilrm)
export(polacz_dane)
export(przygotuj_absolwenci)
export(przygotuj_studenci)
export(przygotuj_szkoly)
export(przygotuj_uczniowie)
export(przygotuj_zbior_osobo_miesiecy_1rm)
export(przygotuj_zbior_osobo_miesiecy_pilrm)
export(przygotuj_zdajacy)
export(wczytaj_wyniki_1rm)
export(wczytaj_wyniki_pilrm)
importFrom(dplyr,"%>%")
importFrom(dplyr,.data)
importFrom(dplyr,anti_join)
importFrom(dplyr,arrange)
importFrom(dplyr,bind_cols)
importFrom(dplyr,bind_rows)
importFrom(dplyr,case_when)
Expand All @@ -21,15 +24,19 @@ importFrom(dplyr,do)
importFrom(dplyr,everything)
importFrom(dplyr,filter)
importFrom(dplyr,filter_)
importFrom(dplyr,first)
importFrom(dplyr,group_by)
importFrom(dplyr,last)
importFrom(dplyr,left_join)
importFrom(dplyr,matches)
importFrom(dplyr,mutate)
importFrom(dplyr,mutate_)
importFrom(dplyr,mutate_all)
importFrom(dplyr,mutate_at)
importFrom(dplyr,n)
importFrom(dplyr,one_of)
importFrom(dplyr,rename)
importFrom(dplyr,right_join)
importFrom(dplyr,select)
importFrom(dplyr,select_)
importFrom(dplyr,starts_with)
Expand All @@ -45,4 +52,5 @@ importFrom(stats,relevel)
importFrom(stats,setNames)
importFrom(tidyr,gather)
importFrom(tidyr,spread)
importFrom(tidyr,unnest)
importFrom(utils,read.csv2)
13 changes: 10 additions & 3 deletions NEWS
Original file line number Diff line number Diff line change
@@ -1,14 +1,21 @@
# MLASZdane 0.0.2 (27.12.2017)
# MLASZdane 0.0.2 (25.02.2019)

- Nowe funkcje:
- przygotuj_zbior_osobo_miesiecy_pilrm();
- przygotuj_zbior_osobo_miesiecy_1rm();
- koryguj_statusy() (nieeksportowana).

# MLASZdane 0.0.2 (27.12.2018)

- Nowe funkcje:
- wczytaj_wyniki_1rm();
- imputuj_mies_pk_1rm().
- imputuj_miesiac_pk_1rm().

# MLASZdane 0.0.2 (27.12.2017)

- Nowe funkcje:
- wczytaj_wyniki_pilrm();
- imputuj_mies_pk_pilrm();
- imputuj_miesiac_pk_pilrm();
- przywroc_etykiety() (nieeksportowana).

# MLASZdane 0.0.1 (23.12.2016)
Expand Down
33 changes: 24 additions & 9 deletions R/imputuj_miesiac_pk_1rm.R
Original file line number Diff line number Diff line change
Expand Up @@ -10,7 +10,7 @@
#' @importFrom stats lm model.frame predict relevel
#' @importFrom dplyr .data bind_rows case_when do filter group_by left_join
#' mutate rename summarise ungroup
imputuj_mies_pk_1rm = function(x) {
imputuj_miesiac_pk_1rm = function(x) {
stopifnot(is.list(x),
all(c("dane", "epizody") %in% names(x)))
mp = options()$max.print
Expand Down Expand Up @@ -123,10 +123,17 @@ imputuj_mies_pk_1rm = function(x) {
return(table(przewidywanie = factor(round(predict(x), 0), levels = l[1]:l[2]),
czas_rozp = factor(model.frame(x)[, 1], levels = l[1]:l[2])))
})
message("R-kwadrat")
lapply(modeleCzas, function(x) {return(summary(x)$r.squared)}) %>% print()
message("odsetek poprawnych klasyfikacji")
lapply(tabeleCzas, function(x) {return(sum(diag(x)) / sum(x))}) %>% print()
cat(" statystyki dopasowania\n")
data.frame(zmienna = names(modeleCzas),
R2 = lapply(modeleCzas, function(x) {return(summary(x)$r.squared)}) %>%
unlist() %>%
round(3),
`odsetek poprawn. klasyf.` =
lapply(tabeleCzas, function(x) {return(sum(diag(x)) / sum(x))}) %>%
unlist() %>%
round(3),
check.names = FALSE) %>%
print(row.names = FALSE)
epizodyImputM = mapply(function(x, m) {
x = suppressWarnings(
x %>%
Expand Down Expand Up @@ -166,10 +173,17 @@ imputuj_mies_pk_1rm = function(x) {
return(table(przewidywanie = factor(round(predict(x), 0), levels = l[1]:l[2]),
dl = factor(model.frame(x)[, 1], levels = l[1]:l[2])))
})
message("R-kwadrat")
lapply(modeleDl, function(x) {return(summary(x)$r.squared)}) %>% print()
message("odsetek poprawnych klasyfikacji")
lapply(tabeleDl, function(x) {return(sum(diag(x)) / sum(x))}) %>% print()
cat(" statystyki dopasowania\n")
data.frame(zmienna = names(modeleDl),
R2 = lapply(modeleDl, function(x) {return(summary(x)$r.squared)}) %>%
unlist() %>%
round(3),
`odsetek poprawn. klasyf.` =
lapply(tabeleDl, function(x) {return(sum(diag(x)) / sum(x))}) %>%
unlist() %>%
round(3),
check.names = FALSE) %>%
print(row.names = FALSE)
epizodyImputM = mapply(function(x, m) {
x = x %>%
mutate(rok_zakon_f =
Expand Down Expand Up @@ -201,6 +215,7 @@ imputuj_mies_pk_1rm = function(x) {
select("ID_RESP", "typ_epizodu", "nr", "czas_rozp", "czas_zakon",
"czy_zakonczony") %>%
rename(imput_czas_rozp = .data$czas_rozp, imput_czas_zakon = .data$czas_zakon)
message("Wyniki imputacji:")
table(imput_czas_rozp = epizodyImput$imput_czas_rozp,
imput_czas_zakon = epizodyImput$imput_czas_zakon, exclude = NULL) %>%
print()
Expand Down
34 changes: 24 additions & 10 deletions R/imputuj_mies_pk_pilrm.R → R/imputuj_miesiac_pk_pilrm.R
Original file line number Diff line number Diff line change
Expand Up @@ -11,7 +11,7 @@
#' @importFrom tidyr gather spread
#' @importFrom dplyr .data bind_rows case_when do filter group_by left_join
#' mutate rename summarise ungroup
imputuj_mies_pk_pilrm = function(x) {
imputuj_miesiac_pk_pilrm = function(x) {
stopifnot(is.list(x),
all(c("dane", "epizody") %in% names(x)))
mp = options()$max.print
Expand Down Expand Up @@ -143,10 +143,17 @@ imputuj_mies_pk_pilrm = function(x) {
return(table(przewidywanie = factor(round(predict(x), 0), levels = l[1]:l[2]),
dl = factor(model.frame(x)[, 1], levels = l[1]:l[2])))
})
message(" R-kwadrat")
lapply(modeleCzas, function(x) {return(summary(x)$r.squared)}) %>% print()
message(" odsetek poprawnych klasyfikacji")
lapply(tabeleCzas, function(x) {return(sum(diag(x)) / sum(x))}) %>% print()
cat(" statystyki dopasowania\n")
data.frame(zmienna = names(modeleCzas),
R2 = lapply(modeleCzas, function(x) {return(summary(x)$r.squared)}) %>%
unlist() %>%
round(3),
`odsetek poprawn. klasyf.` =
lapply(tabeleCzas, function(x) {return(sum(diag(x)) / sum(x))}) %>%
unlist() %>%
round(3),
check.names = FALSE) %>%
print(row.names = FALSE)
epizodyImputM = mapply(function(x, m) {
x = suppressWarnings(
x %>%
Expand Down Expand Up @@ -186,11 +193,17 @@ imputuj_mies_pk_pilrm = function(x) {
return(table(przewidywanie = factor(round(predict(x), 0), levels = l[1]:l[2]),
dl = factor(model.frame(x)[, 1], levels = l[1]:l[2])))
})

message(" R-kwadrat")
lapply(modeleDl, function(x) {return(summary(x)$r.squared)}) %>% print()
message(" odsetek poprawnych klasyfikacji")
lapply(tabeleDl, function(x) {return(sum(diag(x)) / sum(x))}) %>% print()
cat(" statystyki dopasowania\n")
data.frame(zmienna = names(modeleDl),
R2 = lapply(modeleDl, function(x) {return(summary(x)$r.squared)}) %>%
unlist() %>%
round(3),
`odsetek poprawn. klasyf.` =
lapply(tabeleDl, function(x) {return(sum(diag(x)) / sum(x))}) %>%
unlist() %>%
round(3),
check.names = FALSE) %>%
print(row.names = FALSE)
epizodyImputM = mapply(function(x, m) {
x = x %>%
mutate(rok_kon_f =
Expand All @@ -216,6 +229,7 @@ imputuj_mies_pk_pilrm = function(x) {
epizodyImput = suppressWarnings(bind_rows(epizodyImputM)) %>%
select("ID", "typ_epizodu", "nr", "czas_rozp", "czas_kon", "czy_zakonczony") %>%
rename(czas_rozp_imput = .data$czas_rozp, czas_kon_imput = .data$czas_kon)
message("Wyniki imputacji:")
table(czas_rozp_imput = epizodyImput$czas_rozp_imput,
czas_kon_imput = epizodyImput$czas_kon_imput, exclude = NULL) %>%
print()
Expand Down
97 changes: 97 additions & 0 deletions R/koryguj_statusy.R
Original file line number Diff line number Diff line change
@@ -0,0 +1,97 @@
#' @title Tworzenie zbioru osobo-miesiecy
#' @description
#' Funkcja odpowiada za rozstrzyganie konfliktów pomiędzy statusami
#' nauki/pracy/bezrobocia w poszczególnych miesiącach wynikającymi z deklaracji
#' respondentów. Jest wykorzystywana wewnątrz wywołań funkcji
#' \code{\link{przygotuj_zbior_osobo_miesiecy_pilrm}}
#' i \code{\link{przygotuj_zbior_osobo_miesiecy_1rm}}.
#' @param x ramka danych obemująca opis statusów \strong{jednego} badanego
#' @param zmiennaID ciąg znaków - nazwa zmiennej przechowującej unikalne ID badanego
#' @param kodyPracyNaCzarno wektor liczbowy - wartości zmiennej \code{praca},
#' które opisują pracę na czarno (czyli takie, które nie wchodzą w formalny
#' konflikt z posiadaniem statusu zarejestrwoanego bezrobotnego)
#' @return ramka danych ze skorygowanymi statusami i dopisanymi kolumnami
#' opisującymi, jakie zmiany zostały dokonane
#' @importFrom dplyr .data case_when mutate right_join select
koryguj_statusy = function(x, zmiennaID,
kodyPracyNaCzarno = vector(mode = "numeric", length = 0)) {
stopifnot(is.character(zmiennaID), length(zmiennaID) == 1,
is.numeric(kodyPracyNaCzarno))
stopifnot(zmiennaID %in% names(x),
zmiennaID == "ID_RESP" | !("ID_RESP" %in% names(x)))
names(x)[names(x) == zmiennaID] = "ID_RESP"

x = suppressMessages(
x %>%
right_join(data.frame(czas = min(x$czas):max(x$czas))) %>%
mutate(praca_a_bezrobocie =
case_when(is.na(.data$praca) | is.na(.data$bezrobocie) ~ "ndt.",
(.data$praca %in% kodyPracyNaCzarno) &
!is.na(.data$bezrobocie) ~ "praca na czarno na bezrobociu",
!(.data$praca %in% c(kodyPracyNaCzarno, NA) &
!is.na(.data$bezrobocie)) ~ "konflikt"),
korekta_ciaglosc_nauki = "ndt."))
# jeśli mamy tylko jeden epizod, niewątpliwie nie ma konfliktów (a kod poniżej się wykrzaczy)
if (nrow(x) == 1) {
return(select(x, -"ID_RESP"))
}
# korekta "konfliktów" pracy i bezrobocia
for (i in 1:(nrow(x) - 1)) {
if (all(!(x$praca[i:(i + 1)] %in% c(kodyPracyNaCzarno, NA)) &
!is.na(x$bezrobocie[i:(i + 1)]))) {
if (i == 1) {
x$praca_a_bezrobocie[i] = "miesiąc graniczny"
} else if (x$imput_praca[i] %in% 0 & x$imput_bezrobocie[i] %in% 1) {
x$bezrobocie[i] = NA
x$praca_a_bezrobocie[i] = "skorygowano bezrobocie"
} else if (x$imput_praca[i] %in% 1 & x$imput_bezrobocie[i] %in% 0) {
x$praca[i] = NA
x$praca_a_bezrobocie[i] = "skorygowano pracę"
} else if (x$imput_praca[i] %in% 0 & x$imput_bezrobocie[i] %in% 0) {
x$praca_a_bezrobocie[i] = "sprzeczne deklaracje resp."
} else if (x$imput_praca[i] %in% 1 & x$imput_bezrobocie[i] %in% 1) {
x$praca_a_bezrobocie[i] = "sprzeczne wyniki imputacji"
}
if ((i + 1) == nrow(x)) {
if (x$imput_praca[i + 1] %in% 0 & x$imput_bezrobocie[i + 1] %in% 1) {
x$bezrobocie[i + 1] = NA
x$praca_a_bezrobocie[i + 1] = "skorygowano bezrobocie"
} else if (x$imput_praca[i + 1] %in% 1 & x$imput_bezrobocie[i + 1] %in% 0) {
x$praca[i + 1] = NA
x$praca_a_bezrobocie[i + 1] = "skorygowano pracę"
} else if (x$imput_praca[i + 1] %in% 0 & x$imput_bezrobocie[i + 1] %in% 0) {
x$praca_a_bezrobocie[i + 1] = "sprzeczne deklaracje resp."
} else if (x$imput_praca[i + 1] %in% 1 & x$imput_bezrobocie[i + 1] %in% 1) {
x$praca_a_bezrobocie[i + 1] = "sprzeczne wyniki imputacji"
}
}
} else if (!(x$praca[i] %in% c(kodyPracyNaCzarno, NA)) &
!is.na(x$bezrobocie[i])) {
x$praca_a_bezrobocie[i] = "miesiąc graniczny"
} else if (!(x$praca[i + 1] %in% c(kodyPracyNaCzarno, NA)) &
!is.na(x$bezrobocie[i + 1])) {
x$praca_a_bezrobocie[i + 1] = "miesiąc graniczny"
}
}
# korekta wakacji, gdy ciągłość nauki
for (i in setdiff(which(x$nauka %in% 2 & (x$czas %% 12) %in% 4), 1:5)) {
if (!is.na(x$nauka[i - 5])) {
x$korekta_ciaglosc_nauki[intersect((i - 4):(i - 1),
which(is.na(x$nauka)))] = "skorygowane"
x$nauka[(i - 4):(i - 1)] =
ifelse(is.na(x$nauka[(i - 4):(i - 1)]),
2, x$nauka[(i - 4):(i - 1)])
}
}
for (i in setdiff(which(x$nauka %in% 3 & (x$czas %% 12) %in% 3), 1:4)) {
if (!is.na(x$nauka[i - 4])) {
x$korekta_ciaglosc_nauki[intersect((i - 3):(i - 1),
which(is.na(x$nauka)))] = "skorygowane"
x$nauka[(i - 3):(i - 1)] =
ifelse(is.na(x$nauka[(i - 3):(i - 1)]),
3, x$nauka[(i - 3):(i - 1)])
}
}
# koniec
return(select(x, -"ID_RESP"))
}
Loading

0 comments on commit e724cde

Please sign in to comment.