sga_lga<-function(db, flag_male, flag_one, prefix='m3_') {
filters<-c('filtr_ciaze_pojedyncze_chlopcy','filtr_ciaze_pojedyncze_dziewczynki','filtr_wieloraka_chlopcy', 'filtr_wieloraka_dziewczynki')
all_filters<-get_filters()
filtr<-filters[as.numeric(!flag_male) * 1 + as.numeric(!flag_one)*2 + 1]
filtr_obj <- all_filters[[filtr]]
filter_str<-filtr_obj$filterstring
path<-getOption('yuxiaAnaliza.lsgsga_data')
filename<-pathcat::path.cat(path, paste0(prefix, if(flag_male) 'ch' else 'dz', if(flag_one) '1' else '2', '.rds'))
gc<-readRDS(filename)
varx<-'preg_weeks'
vary<-'preg_weight'
mydt<-db %>% filter_(filter_str) %>% select_(.dots=c(varx, vary))
df<-decorate_quantiles(m4 = readRDS(filename), mydt = mydt, varx = varx, vary = vary)$df
df$perc<-as.numeric(df$perc)
dflo <- df %>% filter(perc<=0.03) %>% select(-perc)
dfhi <- df %>% filter(perc>=0.97) %>% select(-perc)
flags_lo<-as.numeric(approxfun(dflo$zn, dflo$zz)(mydt$preg_weeks)>mydt$preg_weight)
sga<-factor(flags_lo+1, labels = c("Noworodki nie-SGA", "Noworodki SGA"))
attr(sga, "label") <- "Przynależność do kategorii SGA"
flags_hi<-as.numeric(approxfun(dfhi$zn, dfhi$zz)(mydt$preg_weeks)<mydt$preg_weight)
lga<-factor(flags_hi+1, labels = c("Noworodki nie-LGA", "Noworodki LGA"))
attr(lga, "label") <- "Przynależność do kategorii LGA"
which_<-which(eval(parse(text=filter_str), envir = db))
return(list(lga=lga, sga=sga, which=which_))
}
apply_sga_lga<-function(db, prefix='m3_') {
lgasga_11<-sga_lga(db, FALSE, FALSE)
lgasga_12<-sga_lga(db, FALSE, TRUE)
lgasga_21<-sga_lga(db, TRUE, FALSE)
lgasga_22<-sga_lga(db, TRUE, TRUE)
#db$sga<-NULL
db$sga<-as.integer(NA)
db[lgasga_11$which,'sga']<-lgasga_11$sga
db[lgasga_12$which,'sga']<-lgasga_12$sga
db[lgasga_21$which,'sga']<-lgasga_21$sga
db[lgasga_22$which,'sga']<-lgasga_22$sga
attributes(db$sga)<-attributes(lgasga_22$sga)
attr(db$sga, 'f.o.b')<-3
db$lga<-as.integer(NA)
db[lgasga_11$which,'lga']<-lgasga_11$lga
db[lgasga_12$which,'lga']<-lgasga_12$lga
db[lgasga_21$which,'lga']<-lgasga_21$lga
db[lgasga_22$which,'lga']<-lgasga_22$lga
attributes(db$lga)<-attributes(lgasga_22$lga)
attr(db$lga, 'f.o.b')<-3
return(db)
}
decorate_quantiles<-function(m4, mydt, varx='varx', vary='vary') {
x<-attr(m4$BB[[varx]], "covariate.35")
nomi.ok <- paste(varx, "ps", 1:ncol(m4$BB[[varx]]), sep = ".")
b<-m4$coefficients[nomi.ok, 1:ncol(m4$coefficients)]
y<-m4$BB[[varx]] %*% b
df<-cbind(as_tibble(y), zn=x) %>% as_tibble %>% tidyr::gather('perc', 'zz', -zn) %>% as_tibble
danesurowe::copy_var_attributes(mydt[[varx]], 'zn', df)
danesurowe::copy_var_attributes(mydt[[vary]], 'zz', df)
setattr(df, 'label', attr(mydt, 'label'))
setattr(df, 'filter_name', attr(mydt, 'filter_name'))
lambda<-min(m4$cv[,'lambdas'])
nfold<-length(colnames(m4$cv)[-1])
return(list(df=df, lambda=lambda, nfold=nfold ))
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.